1       subroutine trauthin(nthinerr)
    2 !--------------------------------------------------------------------------
    3 !
    4 !  TRACK THIN LENS PART
    5 !
    6 !
    7 !  F. SCHMIDT
    8 !
    9 !
   10 !  CHANGES FOR COLLIMATION MADE BY G. ROBERT-DEMOLAIZE, October 29th, 2004
   11 !--------------------------------------------------------------------------
   12       implicit none
   13       integer i,ix,j,jb,jj,jx,kpz,kzz,napx0,nbeaux,nmz,nthinerr
   14       double precision benkcc,cbxb,cbzb,cikveb,crkveb,crxb,crzb,r0,r000,&
   15      &r0a,r2b,rb,rho2b,rkb,tkb,xbb,xrb,zbb,zrb
   16       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
   17      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
   18      &nrco,ntr,nzfz
   19       parameter(npart = 64,nmac = 1)
   20       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
   21      &nzfz = 300000,mmul = 11)
   22       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
   23      &nema = 15)
   24       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
   25       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
   26       parameter(nmon1 = 600,ncor1 = 600)
   27       parameter(ntr = 20,nbb = 160)
   28       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
   29      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
   30      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
   31      &one,pieni,pmae,pmap,three,two,zero
   32       parameter(pieni = 1d-38)
   33       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
   34       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
   35       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
   36       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
   37       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
   38      &1.0d16)
   39       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
   40       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
   41       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
   42       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
   43       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
   44       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
   45       parameter(pmap = 938.271998d0,pmae = .510998902d0)
   46       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
   47       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
   48      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
   49      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
   50      &imc,imtr,iorg,iout,                                               &
   51      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
   52      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
   53      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
   54      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
   55      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
   56      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
   57      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
   58      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
   59      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
   60       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
   61      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
   62      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
   63      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
   64      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
   65      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
   66      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
   67      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
   68      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
   69      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
   70      &acdipph
   71       real hmal
   72       character*16 bez,bezb,bezr,erbez,bezl
   73       character*80 toptit,sixtit,commen
   74       common/erro/ierro,erbez
   75       common/kons/pi,pi2,pisqrt,rad
   76       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
   77       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
   78       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
   79       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
   80       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
   81       common/syos2/rvf(mpa)
   82       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
   83      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
   84       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
   85      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
   86      &iicav,itionc(nele),ition,idp,ncy,ixcav
   87       common/corcom/dpscor,sigcor,icode,idam,its6d
   88       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
   89      &bka(nele,mmul),aka(nele,mmul)
   90       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
   91       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
   92       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
   93      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
   94       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
   95       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
   96      &iout
   97       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
   98       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
   99      &ntco,eui,euii,nlin,bezl(nele)
  100       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
  101      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
  102      &ncororb(nele)
  103       common/apert/apx(nele),apz(nele),ape(3,nele)
  104       common/clos/sigma0(2),iclo,ncorru,ncorrep
  105       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
  106      &ratioe(nele),iratioe(nele),icoe
  107       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
  108       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
  109       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
  110       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
  111       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
  112      &nstart,nstop,iskip,iconv,imad
  113       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
  114       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
  115       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
  116       common/ripp2/nrturn
  117       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
  118       common/pawc/hmal(nplo)
  119       common/tit/sixtit,commen,ithick
  120       common/co6d/clo6(3),clop6(3)
  121       common/dkic/dki(nele,3)
  122       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
  123      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
  124      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
  125      &nbeam,ibbc,ibeco,ibtyp,lhc
  126       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
  127       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
  128       common/wireco/ wirel(nele)
  129       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
  130      &nturn3(nele), nturn4(nele)
  131       integer idz,itra
  132       double precision al,as,chi0,chid,dp1,dps,exz,sigm
  133       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
  134      &dps(mpa),idz(2)
  135       common/anf/chi0,chid,exz(2,6),dp1,itra
  136       integer ichrom,is
  137       double precision alf0,amp,bet0,clo,clop,cro,x,y
  138       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
  139       common/chrom/cro(2),is(2),ichrom
  140       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
  141      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
  142       double precision dpmax,preda,weig1,weig2
  143       character*16 coel
  144       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
  145       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
  146       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
  147      &coel(10)
  148       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
  149      &zsi
  150       real tlim,time0,time1
  151       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
  152      &aai(nblz,mmul),bbi(nblz,mmul)
  153       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
  154       common/damp/damp,ampt
  155       common/ttime/tlim,time0,time1
  156       double precision tasm
  157       common/tasm/tasm(6,6)
  158       integer iv,ixv,nlostp,nms,numxv
  159       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
  160      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
  161      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
  162      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
  163      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
  164      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
  165      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
  166      &zsiv,zsv
  167       logical pstop
  168       common/main1/                                                     &
  169      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
  170      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
  171      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
  172      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
  173      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
  174      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
  175      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
  176      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
  177       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
  178      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
  179      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
  180      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
  181      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
  182      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
  183      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
  184      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
  185      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
  186       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
  187      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
  188      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
  189      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
  190       integer numx
  191       double precision e0f
  192       common/main4/ e0f,numx
  193       integer ktrack,nwri
  194       double precision dpsv1,strack,strackc,stracks
  195       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
  196      &stracks(nblz),dpsv1(npart),nwri
  197       double precision cc,xlim,ylim
  198       parameter(cc = 1.12837916709551d0)
  199       parameter(xlim = 5.33d0)
  200       parameter(ylim = 4.29d0)
  201       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
  202      &r2b(npart),rb(npart),rkb(npart),                                  &
  203      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
  204      &crzb(npart),cbxb(npart),cbzb(npart)
  205       dimension nbeaux(nbb)
  206       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
  207       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
  208      &maxn=20000,outlun=54)
  209       integer   mynp
  210       common /mynp/ mynp
  211 !
  212       logical cut_input
  213       common /cut/ cut_input
  214 !
  215 !++ Vectors of coordinates
  216       double precision myemitx,mygammax,myemity,mygammay,xsigmax,ysigmay
  217 !
  218       real rndm4
  219 !
  220       character*80 dummy
  221 !
  222       double precision remitxn,remityn,remitx,remity
  223       common  /remit/ remitxn, remityn, remitx, remity
  224 !
  225       double precision mux(nblz),muy(nblz)
  226       common /mu/ mux,muy
  227 !
  228       double precision ielem,iclr,grd
  229       character*80 ch
  230       character*160 ch1
  231       logical flag
  232 !
  233       integer k,np0,rnd_lux,rnd_k1,rnd_k2
  234 !
  235       double precision ax0,ay0,bx0,by0,mux0,muy0,nspx,nspy
  236 !
  237       double precision xbob(nblz),ybob(nblz),xpbob(nblz),ypbob(nblz),   &
  238      &xineff(npart),yineff(npart),xpineff(npart),ypineff(npart)
  239 !
  240       common /xcheck/ xbob,ybob,xpbob,ypbob,xineff,yineff,xpineff,      &
  241      &ypineff
  242 !
  243       integer   mclock_liar
  244 !
  245       character*160 cmd
  246       character*160 cmd2
  247       character*1 ch0
  248       character*2 ch00
  249       character*3 ch000
  250       character*4 ch0000
  251 !
  252 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  253 !
  254 !GRD
  255 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
  256 !GRD
  257 !APRIL2005
  258       logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside,     &
  259      &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial,        &
  260      &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
  261 !
  262       integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber,         &
  263      &do_thisdis,n_slices,pencil_distr
  264       double precision myenom,mynex,mdex,myney,mdey,                    &
  265      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
  266      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
  267 !
  268      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
  269      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
  270 !
  271      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
  272 !SEPT2005 add these lines for the slicing procedure
  273      &smin_slices,smax_slices,recenter1,recenter2,                      &
  274      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
  275      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
  276 !SEPT2005,OCT2006 added offset
  277      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
  278      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
  279      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
  280      &c_sysoffset_sec,c_rmserror_gap,nr,ndr,                            &
  281 !     &driftsx,driftsy,pencil_offset,sigsecut3
  282 !JUNE2005
  283      &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,            &
  284      &sigsecut3,sigsecut2,enerror,bunchlength
  285 !
  286       character*24 name_sel
  287       character*80 coll_db
  288       character*16 castordir
  289 !JUNE2005
  290       character*80 filename_dis
  291 !JUNE2005
  292       common /grd/ myenom,mynex,mdex,myney,mdey,                        &
  293      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
  294      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
  295 !
  296      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
  297      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
  298 !
  299      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
  300 !
  301      &smin_slices,smax_slices,recenter1,recenter2,                      &
  302      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
  303      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
  304 !
  305      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
  306      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
  307      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
  308      &c_sysoffset_sec,c_rmserror_gap,nr,                                &
  309 !
  310      &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,        &
  311      &sigsecut3,sigsecut2,enerror,                                      &
  312      &bunchlength,coll_db,name_sel,                                     &
  313      &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed,          &
  314      &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr,                 &
  315      &do_coll,                                                          &
  316 !
  317      &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
  318      &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
  319      &dowritetracks,cern,do_nsig,do_mingap
  320 !
  321 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  322 !
  323 !
  324 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
  325 !
  326       integer ieff
  327 !
  328       double precision myemitx0,myemity0,myalphay,mybetay,myalphax,     &
  329      &mybetax,rselect
  330       common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax,       &
  331      &mybetay,rselect
  332 !
  333       integer absorbed(npart),counted(npart,numeff)
  334       double precision neff(numeff),rsig(numeff)
  335       common  /eff/ neff,rsig,counted,absorbed
  336 !
  337       integer  nimpact(50)
  338       double precision sumimpact(50),sqsumimpact(50)
  339       common  /rimpact/ sumimpact,sqsumimpact,nimpact
  340 !
  341       integer  nampl(nblz)
  342       character*16  ename(nblz)
  343       double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz),        &
  344      &sqsum_ay(nblz),sampl(nblz)
  345       common  /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename,   &
  346      &nampl
  347 !
  348       double precision neffx(numeff),neffy(numeff)
  349       common /efficiency/ neffx,neffy
  350 !
  351       integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed   &
  352      &,part_select(maxn)
  353       double precision part_impact(maxn)
  354       common /stats/ part_impact,part_hit,part_abs
  355       common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
  356       common /part_select/ part_select
  357 !
  358       double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
  359       common   /beam00/ x00,xp00,y00,yp00
  360 !
  361       logical firstrun
  362       common /firstrun/ firstrun
  363 !
  364       integer nsurvive,nsurvive_end,num_selhit,n_impact
  365       common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
  366 !
  367       integer napx00
  368       common /napx00/ napx00
  369 !
  370       integer  icoll
  371       common  /icoll/  icoll
  372
  373
  374 !
  375       integer db_ncoll
  376 !
  377       character*16 db_name1(max_ncoll),db_name2(max_ncoll)
  378       character*6 db_material(max_ncoll)
  379       double precision db_nsig(max_ncoll),db_length(max_ncoll),         &
  380      &db_offset(max_ncoll),db_rotation(max_ncoll),                      &
  381      &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2),           &
  382      &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll)
  383      &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll),                  &
  384      &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll),                  &
  385      &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
  386      &,db_miscut(max_ncoll)
  387       common /colldatabase/ db_nsig,db_length,db_rotation,db_offset,    &
  388      &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll,       &
  389      &db_elense_thickness,db_elense_j_e
  390      &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
  391      &db_cry_tilt,db_miscut
  392 !
  393       integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
  394       double precision caverage(max_ncoll),csigma(max_ncoll)
  395       common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
  396 !
  397       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
  398      &myp(maxn),mys(maxn)
  399       common /coord/ myx,myxp,myy,myyp,myp,mys
  400 !
  401       integer counted_r(maxn,numeff),counted_x(maxn,numeff),            &
  402      &counted_y(maxn,numeff),                                           &
  403      &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
  404       common /counting/ counted_r,counted_x,counted_y,ieffmax_r,        &
  405      &ieffmax_x, ieffmax_y
  406 !
  407       integer secondary(maxn),tertiary(maxn),other(maxn),               &
  408      &part_hit_before(maxn)
  409       double precision part_indiv(maxn),part_linteract(maxn)
  410 !
  411       integer   samplenumber
  412       character*4 smpl
  413       character*80 pfile
  414       common /samplenumber/ pfile,smpl,samplenumber
  415 !
  416 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  417 !
  418 !
  419 ! THIS BLOCK IS COMMON TO WRITELIN,LINOPT,TRAUTHIN,THIN6D AND MAINCR
  420 !
  421       double precision tbetax(nblz),tbetay(nblz),talphax(nblz),         &
  422      &talphay(nblz),torbx(nblz),torbxp(nblz),torby(nblz),torbyp(nblz),  &
  423      &tdispx(nblz),tdispy(nblz)
  424 !
  425       common /rtwiss/ tbetax,tbetay,talphax,talphay,torbx,torbxp,       &
  426      &torby,torbyp,tdispx,tdispy
  427 !
  428 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  429 !
  430 !
  431 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
  432 !
  433       integer ipencil
  434       double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll),       &
  435      &y_pencil(max_ncoll),pencil_dx(max_ncoll)
  436       common  /pencil/  xp_pencil0,yp_pencil0,pencil_dx,ipencil
  437       common  /pencil2/ x_pencil, y_pencil
  438 !
  439 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  440 !
  441       integer ie,iturn,nabs_total
  442       common  /info/ ie,iturn,nabs_total
  443 !
  444 !
  445 ! SEPT2008: valentina add flags for cry output
  446 !
  447       logical write_c_out, write_SPS_out
  448       common /outputs/ write_c_out, write_SPS_out
  449
  450
  451       double precision xdebug(nblz),xdebugN(nblz),xpdebug(nblz),
  452      & xpdebugN(nblz),
  453      & ydebug(nblz),ydebugN(nblz),ypdebug(nblz),ypdebugN(nblz)
  454       common /debugvale/xdebug,xdebugN,xpdebug,xpdebugN,
  455      &ydebug,ydebugN,ypdebug,ypdebugN
  456       
  457       save
  458 !-----------------------------------------------------------------------
  459       write_c_out= .true. !valentina
  460 c
  461 c
  462 c    
  463       do 5 i=1,npart
  464         nlostp(i)=i
  465    5  continue
  466       do 10 i=1,nblz
  467         ktrack(i)=0
  468         strack(i)=zero
  469         strackc(i)=zero
  470         stracks(i)=zero
  471    10 continue
  472 !--beam-beam element
  473       if(nbeam.ge.1) then
  474         do 15 i=1,nbb
  475           nbeaux(i)=0
  476    15   continue
  477         do i=1,iu
  478           ix=ic(i)
  479           if(ix.gt.nblo) then
  480             ix=ix-nblo
  481             if(kz(ix).eq.20.and.parbe(ix,2).eq.0) then
  482 !--round beam
  483               if(sigman(1,imbb(i)).eq.sigman(2,imbb(i))) then
  484                 if(nbeaux(imbb(i)).eq.2.or.nbeaux(imbb(i)).eq.3) then
  485                   call prror(89)
  486                 else
  487                   nbeaux(imbb(i))=1
  488                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
  489                 endif
  490               endif
  491 !--elliptic beam x>z
  492               if(sigman(1,imbb(i)).gt.sigman(2,imbb(i))) then
  493                 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.3) then
  494                   call prror(89)
  495                 else
  496                   nbeaux(imbb(i))=2
  497                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
  498                   sigman2(2,imbb(i))=sigman(2,imbb(i))**2
  499                   sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
  500                   sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
  501                 endif
  502               endif
  503 !--elliptic beam z>x
  504               if(sigman(1,imbb(i)).lt.sigman(2,imbb(i))) then
  505                 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.2) then
  506                   call prror(89)
  507                 else
  508                   nbeaux(imbb(i))=3
  509                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
  510                   sigman2(2,imbb(i))=sigman(2,imbb(i))**2
  511                   sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
  512                   sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
  513                 endif
  514               endif
  515             endif
  516           endif
  517         enddo
  518       endif
  519       
  520       do 290 i=1,iu
  521         if(mout2.eq.1.and.i.eq.1) call write4
  522         ix=ic(i)
  523         if(ix.gt.nblo) goto 30
  524         ktrack(i)=1
  525         do 20 jb=1,mel(ix)
  526           jx=mtyp(ix,jb)
  527           strack(i)=strack(i)+el(jx)
  528    20   continue
  529         if(abs(strack(i)).le.pieni) ktrack(i)=31
  530         goto 290
  531    30   ix=ix-nblo
  532         kpz=abs(kp(ix))
  533         if(kpz.eq.6) then
  534           ktrack(i)=2
  535           goto 290
  536         endif
  537    40   kzz=kz(ix)
  538         if(kzz.eq.0) then
  539           ktrack(i)=31
  540           goto 290
  541         endif
  542 !--beam-beam element
  543         if(kzz.eq.20.and.nbeam.ge.1.and.parbe(ix,2).eq.0) then
  544           strack(i)=crad*ptnfac(ix)
  545           if(abs(strack(i)).le.pieni) then
  546             ktrack(i)=31
  547             goto 290
  548           endif
  549           if(nbeaux(imbb(i)).eq.1) then
  550             ktrack(i)=41
  551             if(ibeco.eq.1) then
  552               do 42 j=1,napx
  553               if(ibbc.eq.0) then
  554                 crkveb(j)=ed(ix)
  555                 cikveb(j)=ek(ix)
  556               else
  557                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
  558      &ek(ix)*bbcu(imbb(i),12)
  559                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
  560      &ek(ix)*bbcu(imbb(i),11)
  561               endif
  562             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
  563             if(rho2b(j).le.pieni)                                       &
  564      &goto 42
  565             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
  566                 beamoff(4,imbb(i))=strack(i)*crkveb(j)/rho2b(j)*        &
  567      &(one-exp(-tkb(j)))
  568                 beamoff(5,imbb(i))=strack(i)*cikveb(j)/rho2b(j)*        &
  569      &(one-exp(-tkb(j)))
  570    42         continue
  571             endif
  572           endif
  573           if(nbeaux(imbb(i)).eq.2) then
  574             ktrack(i)=42
  575             if(ibeco.eq.1) then
  576             if(ibtyp.eq.0) then
  577             do j=1,napx
  578               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
  579               rb(j)=sqrt(r2b(j))
  580               rkb(j)=strack(i)*pisqrt/rb(j)
  581               if(ibbc.eq.0) then
  582                 crkveb(j)=ed(ix)
  583                 cikveb(j)=ek(ix)
  584               else
  585                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
  586      &ek(ix)*bbcu(imbb(i),12)
  587                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
  588      &ek(ix)*bbcu(imbb(i),11)
  589               endif
  590               xrb(j)=abs(crkveb(j))/rb(j)
  591               zrb(j)=abs(cikveb(j))/rb(j)
  592               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
  593               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
  594      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
  595               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
  596               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
  597               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
  598               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
  599      &sign(one,crkveb(j))
  600               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
  601      &sign(one,cikveb(j))
  602             enddo
  603             else if(ibtyp.eq.1) then
  604             do j=1,napx
  605               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
  606               rb(j)=sqrt(r2b(j))
  607               rkb(j)=strack(i)*pisqrt/rb(j)
  608               if(ibbc.eq.0) then
  609                 crkveb(j)=ed(ix)
  610                 cikveb(j)=ek(ix)
  611               else
  612                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
  613      &ek(ix)*bbcu(imbb(i),12)
  614                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
  615      &ek(ix)*bbcu(imbb(i),11)
  616               endif
  617               xrb(j)=abs(crkveb(j))/rb(j)
  618               zrb(j)=abs(cikveb(j))/rb(j)
  619               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
  620      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
  621               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
  622               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
  623             enddo
  624             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
  625             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
  626             do j=1,napx
  627               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
  628      &sign(one,crkveb(j))
  629               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
  630      &sign(one,cikveb(j))
  631             enddo
  632             endif
  633             endif
  634           endif
  635           if(nbeaux(imbb(i)).eq.3) then
  636             ktrack(i)=43
  637             if(ibeco.eq.1) then
  638             if(ibtyp.eq.0) then
  639             do j=1,napx
  640               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
  641               rb(j)=sqrt(r2b(j))
  642               rkb(j)=strack(i)*pisqrt/rb(j)
  643               if(ibbc.eq.0) then
  644                 crkveb(j)=ed(ix)
  645                 cikveb(j)=ek(ix)
  646               else
  647                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
  648      &ek(ix)*bbcu(imbb(i),12)
  649                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
  650      &ek(ix)*bbcu(imbb(i),11)
  651               endif
  652               xrb(j)=abs(crkveb(j))/rb(j)
  653               zrb(j)=abs(cikveb(j))/rb(j)
  654               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
  655               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
  656      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
  657               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
  658               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
  659               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
  660               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
  661      &sign(one,crkveb(j))
  662               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
  663      &sign(one,cikveb(j))
  664             enddo
  665             else if(ibtyp.eq.1) then
  666             do j=1,napx
  667               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
  668               rb(j)=sqrt(r2b(j))
  669               rkb(j)=strack(i)*pisqrt/rb(j)
  670               if(ibbc.eq.0) then
  671                 crkveb(j)=ed(ix)
  672                 cikveb(j)=ek(ix)
  673               else
  674                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
  675      &ek(ix)*bbcu(imbb(i),12)
  676                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
  677      &ek(ix)*bbcu(imbb(i),11)
  678               endif
  679               xrb(j)=abs(crkveb(j))/rb(j)
  680               zrb(j)=abs(cikveb(j))/rb(j)
  681               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
  682      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
  683               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
  684               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
  685             enddo
  686             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
  687             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
  688             do j=1,napx
  689               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
  690      &sign(one,crkveb(j))
  691               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
  692      &sign(one,cikveb(j))
  693             enddo
  694             endif
  695             endif
  696           endif
  697           goto 290
  698 !--Hirata's 6D beam-beam kick
  699         else if(kzz.eq.20.and.parbe(ix,2).gt.0) then
  700           ktrack(i)=44
  701           parbe(ix,4)=-crad*ptnfac(ix)*half*c1m6
  702           if(ibeco.eq.1) then
  703             track6d(1,1)=ed(ix)*c1m3
  704             track6d(2,1)=zero
  705             track6d(3,1)=ek(ix)*c1m3
  706             track6d(4,1)=zero
  707             track6d(5,1)=zero
  708             track6d(6,1)=zero
  709             napx0=napx
  710             napx=1
  711             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
  712      &ibbc)
  713             beamoff(1,imbb(i))=track6d(1,1)*c1e3
  714             beamoff(2,imbb(i))=track6d(3,1)*c1e3
  715             beamoff(4,imbb(i))=track6d(2,1)*c1e3
  716             beamoff(5,imbb(i))=track6d(4,1)*c1e3
  717             beamoff(6,imbb(i))=track6d(6,1)
  718             napx=napx0
  719           endif
  720           goto 290
  721         endif
  722         if(kzz.eq.15) then
  723           ktrack(i)=45
  724           goto 290
  725         endif
  726         if(kzz.eq.16) then
  727           ktrack(i)=51
  728           goto 290
  729         else if(kzz.eq.-16) then
  730           ktrack(i)=52
  731           goto 290
  732         endif
  733         if(kzz.eq.22) then
  734           ktrack(i)=3
  735           goto 290
  736         endif
  737         if(mout2.eq.1.and.icextal(i).ne.0) then
  738           write(27,'(a16,2x,1p,2d14.6,d17.9)') bez(ix),extalign(i,1),   &
  739      &extalign(i,2),extalign(i,3)
  740         endif
  741         if(kzz.lt.0) goto 180
  742         goto(50,60,70,80,90,100,110,120,130,140,150),kzz
  743         ktrack(i)=31
  744         goto 290
  745    50   if(abs(smiv(1,i)).le.pieni) then
  746           ktrack(i)=31
  747           goto 290
  748         endif
  749         ktrack(i)=11
  750         strack(i)=smiv(1,i)*c1e3
  751         strackc(i)=strack(i)*tiltc(i)
  752         stracks(i)=strack(i)*tilts(i)
  753         goto 290
  754    60   if(abs(smiv(1,i)).le.pieni.and.abs(ramp(ix)).le.pieni) then
  755           ktrack(i)=31
  756           goto 290
  757         endif
  758         ktrack(i)=12
  759         strack(i)=smiv(1,i)
  760         strackc(i)=strack(i)*tiltc(i)
  761         stracks(i)=strack(i)*tilts(i)
  762         goto 290
  763    70   if(abs(smiv(1,i)).le.pieni) then
  764           ktrack(i)=31
  765           goto 290
  766         endif
  767         ktrack(i)=13
  768         strack(i)=smiv(1,i)*c1m3
  769         strackc(i)=strack(i)*tiltc(i)
  770         stracks(i)=strack(i)*tilts(i)
  771         goto 290
  772    80   if(abs(smiv(1,i)).le.pieni) then
  773           ktrack(i)=31
  774           goto 290
  775         endif
  776         ktrack(i)=14
  777         strack(i)=smiv(1,i)*c1m6
  778         strackc(i)=strack(i)*tiltc(i)
  779         stracks(i)=strack(i)*tilts(i)
  780         goto 290
  781    90   if(abs(smiv(1,i)).le.pieni) then
  782           ktrack(i)=31
  783           goto 290
  784         endif
  785         ktrack(i)=15
  786         strack(i)=smiv(1,i)*c1m9
  787         strackc(i)=strack(i)*tiltc(i)
  788         stracks(i)=strack(i)*tilts(i)
  789         goto 290
  790   100   if(abs(smiv(1,i)).le.pieni) then
  791           ktrack(i)=31
  792           goto 290
  793         endif
  794         ktrack(i)=16
  795         strack(i)=smiv(1,i)*c1m12
  796         strackc(i)=strack(i)*tiltc(i)
  797         stracks(i)=strack(i)*tilts(i)
  798         goto 290
  799   110   if(abs(smiv(1,i)).le.pieni) then
  800           ktrack(i)=31
  801           goto 290
  802         endif
  803         ktrack(i)=17
  804         strack(i)=smiv(1,i)*c1m15
  805         strackc(i)=strack(i)*tiltc(i)
  806         stracks(i)=strack(i)*tilts(i)
  807         goto 290
  808   120   if(abs(smiv(1,i)).le.pieni) then
  809           ktrack(i)=31
  810           goto 290
  811         endif
  812         ktrack(i)=18
  813         strack(i)=smiv(1,i)*c1m18
  814         strackc(i)=strack(i)*tiltc(i)
  815         stracks(i)=strack(i)*tilts(i)
  816         goto 290
  817   130   if(abs(smiv(1,i)).le.pieni) then
  818           ktrack(i)=31
  819           goto 290
  820         endif
  821         ktrack(i)=19
  822         strack(i)=smiv(1,i)*c1m21
  823         strackc(i)=strack(i)*tiltc(i)
  824         stracks(i)=strack(i)*tilts(i)
  825         goto 290
  826   140   if(abs(smiv(1,i)).le.pieni) then
  827           ktrack(i)=31
  828           goto 290
  829         endif
  830         ktrack(i)=20
  831         strack(i)=smiv(1,i)*c1m24
  832         strackc(i)=strack(i)*tiltc(i)
  833         stracks(i)=strack(i)*tilts(i)
  834         goto 290
  835   150   r0=ek(ix)
  836         nmz=nmu(ix)
  837         if(abs(r0).le.pieni.or.nmz.eq.0) then
  838           if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
  839             ktrack(i)=31
  840           else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni)  &
  841      &then
  842             if(abs(dki(ix,3)).gt.pieni) then
  843               ktrack(i)=33
  844               strack(i)=dki(ix,1)/dki(ix,3)
  845               strackc(i)=strack(i)*tiltc(i)
  846               stracks(i)=strack(i)*tilts(i)
  847             else
  848               ktrack(i)=35
  849               strack(i)=dki(ix,1)
  850               strackc(i)=strack(i)*tiltc(i)
  851               stracks(i)=strack(i)*tilts(i)
  852             endif
  853           else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni)  &
  854      &then
  855             if(abs(dki(ix,3)).gt.pieni) then
  856               ktrack(i)=37
  857               strack(i)=dki(ix,2)/dki(ix,3)
  858               strackc(i)=strack(i)*tiltc(i)
  859               stracks(i)=strack(i)*tilts(i)
  860             else
  861               ktrack(i)=39
  862               strack(i)=dki(ix,2)
  863               strackc(i)=strack(i)*tiltc(i)
  864               stracks(i)=strack(i)*tilts(i)
  865             endif
  866           endif
  867         else
  868           if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
  869             ktrack(i)=32
  870           else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni)  &
  871      &then
  872             if(abs(dki(ix,3)).gt.pieni) then
  873               ktrack(i)=34
  874               strack(i)=dki(ix,1)/dki(ix,3)
  875               strackc(i)=strack(i)*tiltc(i)
  876               stracks(i)=strack(i)*tilts(i)
  877             else
  878               ktrack(i)=36
  879               strack(i)=dki(ix,1)
  880               strackc(i)=strack(i)*tiltc(i)
  881               stracks(i)=strack(i)*tilts(i)
  882             endif
  883           else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni)  &
  884      &then
  885             if(abs(dki(ix,3)).gt.pieni) then
  886               ktrack(i)=38
  887               strack(i)=dki(ix,2)/dki(ix,3)
  888               strackc(i)=strack(i)*tiltc(i)
  889               stracks(i)=strack(i)*tilts(i)
  890             else
  891               ktrack(i)=40
  892               strack(i)=dki(ix,2)
  893               strackc(i)=strack(i)*tiltc(i)
  894               stracks(i)=strack(i)*tilts(i)
  895             endif
  896           endif
  897         endif
  898         if(abs(r0).le.pieni.or.nmz.eq.0) goto 290
  899         if(mout2.eq.1) then
  900           benkcc=ed(ix)*benkc(irm(ix))
  901           r0a=one
  902           r000=r0*r00(irm(ix))
  903           do 160 j=1,mmul
  904             fake(1,j)=bbiv(j,1,i)*r0a/benkcc
  905             fake(2,j)=aaiv(j,1,i)*r0a/benkcc
  906   160     r0a=r0a*r000
  907           write(9,'(a16)') bez(ix)
  908           write(9,'(1p,3d23.15)') (fake(1,j), j=1,3)
  909           write(9,'(1p,3d23.15)') (fake(1,j), j=4,6)
  910           write(9,'(1p,3d23.15)') (fake(1,j), j=7,9)
  911           write(9,'(1p,3d23.15)') (fake(1,j), j=10,12)
  912           write(9,'(1p,3d23.15)') (fake(1,j), j=13,15)
  913           write(9,'(1p,3d23.15)') (fake(1,j), j=16,18)
  914           write(9,'(1p,2d23.15)') (fake(1,j), j=19,20)
  915           write(9,'(1p,3d23.15)') (fake(2,j), j=1,3)
  916           write(9,'(1p,3d23.15)') (fake(2,j), j=4,6)
  917           write(9,'(1p,3d23.15)') (fake(2,j), j=7,9)
  918           write(9,'(1p,3d23.15)') (fake(2,j), j=10,12)
  919           write(9,'(1p,3d23.15)') (fake(2,j), j=13,15)
  920           write(9,'(1p,3d23.15)') (fake(2,j), j=16,18)
  921           write(9,'(1p,2d23.15)') (fake(2,j), j=19,20)
  922           do 170 j=1,20
  923             fake(1,j)=zero
  924   170     fake(2,j)=zero
  925         endif
  926         goto 290
  927   180   kzz=-kzz
  928         goto(190,200,210,220,230,240,250,260,270,280),kzz
  929         ktrack(i)=31
  930         goto 290
  931   190   if(abs(smiv(1,i)).le.pieni) then
  932           ktrack(i)=31
  933           goto 290
  934         endif
  935         ktrack(i)=21
  936         strack(i)=smiv(1,i)*c1e3
  937         strackc(i)=strack(i)*tiltc(i)
  938         stracks(i)=strack(i)*tilts(i)
  939         goto 290
  940   200   if(abs(smiv(1,i)).le.pieni) then
  941           ktrack(i)=31
  942           goto 290
  943         endif
  944         ktrack(i)=22
  945         strack(i)=smiv(1,i)
  946         strackc(i)=strack(i)*tiltc(i)
  947         stracks(i)=strack(i)*tilts(i)
  948         goto 290
  949   210   if(abs(smiv(1,i)).le.pieni) then
  950           ktrack(i)=31
  951           goto 290
  952         endif
  953         ktrack(i)=23
  954         strack(i)=smiv(1,i)*c1m3
  955         strackc(i)=strack(i)*tiltc(i)
  956         stracks(i)=strack(i)*tilts(i)
  957         goto 290
  958   220   if(abs(smiv(1,i)).le.pieni) then
  959           ktrack(i)=31
  960           goto 290
  961         endif
  962         ktrack(i)=24
  963         strack(i)=smiv(1,i)*c1m6
  964         strackc(i)=strack(i)*tiltc(i)
  965         stracks(i)=strack(i)*tilts(i)
  966         goto 290
  967   230   if(abs(smiv(1,i)).le.pieni) then
  968           ktrack(i)=31
  969           goto 290
  970         endif
  971         ktrack(i)=25
  972         strack(i)=smiv(1,i)*c1m9
  973         strackc(i)=strack(i)*tiltc(i)
  974         stracks(i)=strack(i)*tilts(i)
  975         goto 290
  976   240   if(abs(smiv(1,i)).le.pieni) then
  977           ktrack(i)=31
  978           goto 290
  979         endif
  980         ktrack(i)=26
  981         strack(i)=smiv(1,i)*c1m12
  982         strackc(i)=strack(i)*tiltc(i)
  983         stracks(i)=strack(i)*tilts(i)
  984         goto 290
  985   250   if(abs(smiv(1,i)).le.pieni) then
  986           ktrack(i)=31
  987           goto 290
  988         endif
  989         ktrack(i)=27
  990         strack(i)=smiv(1,i)*c1m15
  991         strackc(i)=strack(i)*tiltc(i)
  992         stracks(i)=strack(i)*tilts(i)
  993         goto 290
  994   260   if(abs(smiv(1,i)).le.pieni) then
  995           ktrack(i)=31
  996           goto 290
  997         endif
  998         ktrack(i)=28
  999         strack(i)=smiv(1,i)*c1m18
 1000         strackc(i)=strack(i)*tiltc(i)
 1001         stracks(i)=strack(i)*tilts(i)
 1002         goto 290
 1003   270   if(abs(smiv(1,i)).le.pieni) then
 1004           ktrack(i)=31
 1005           goto 290
 1006         endif
 1007         ktrack(i)=29
 1008         strack(i)=smiv(1,i)*c1m21
 1009         strackc(i)=strack(i)*tiltc(i)
 1010         stracks(i)=strack(i)*tilts(i)
 1011         goto 290
 1012   280   if(abs(smiv(1,i)).le.pieni) then
 1013           ktrack(i)=31
 1014           goto 290
 1015         endif
 1016         ktrack(i)=30
 1017         strack(i)=smiv(1,i)*c1m24
 1018         strackc(i)=strack(i)*tiltc(i)
 1019         stracks(i)=strack(i)*tilts(i)
 1020   290 continue
 1021
 1022         
 1023       do 300 j=1,napx
 1024         dpsv1(j)=dpsv(j)*c1e3/(one+dpsv(j))
 1025   300 continue
 1026       nwri=nwr(3)
 1027       if(nwri.eq.0) nwri=numl+numlr+1
 1028       if(idp.eq.0.or.ition.eq.0) then
 1029         call thin4d(nthinerr)
 1030       else
 1031         hsy(3)=c1m3*hsy(3)*ition
 1032         do 310 jj=1,nele
 1033           if(kz(jj).eq.12) hsyc(jj)=c1m3*hsyc(jj)*itionc(jj)
 1034   310   continue
 1035         if(abs(phas).ge.pieni) then
 1036           call thin6dua(nthinerr)
 1037         else
 1038       open(unit=outlun, file='colltrack.out')
 1039 !
 1040       write(*,*)
 1041       write(*,*) '         -------------------------------'
 1042       write(*,*)
 1043       write(*,*) '          Program      C O L L T R A C K '
 1044       write(*,*)
 1045       write(*,*) '            R. Assmann           -    AB/ABP'
 1046       write(*,*) '            C. Bracco            -    AB/ABP'
 1047       write(*,*) '            V. Previtali         -    AB/ABP'
 1048       write(*,*) '            S. Redaelli          -    AB/OP'
 1049       write(*,*) '            G. Robert-Demolaize  -    AB/ABP'
 1050       write(*,*) '            T. Weiler            -    AB/ABP'
 1051       write(*,*)
 1052       write(*,*) '                 CERN 2001 - 2007'
 1053       write(*,*)
 1054       write(*,*) '         -------------------------------'
 1055       write(*,*)
 1056       write(*,*)
 1057       write(outlun,*)
 1058       write(outlun,*)
 1059       write(outlun,*) '       -------------------------------'
 1060       write(outlun,*)
 1061       write(outlun,*) '       Program      C O L L T R A C K '
 1062       write(outlun,*)
 1063       write(outlun,*) '          R. Assmann             -    AB/ABP'
 1064       write(outlun,*) '          C. Bracco              -    AB/ABP'
 1065       write(outlun,*) '          V. Previtali           -    AB/ABP'
 1066       write(outlun,*) '          S. Redaelli            -    AB/OP'
 1067       write(outlun,*) '          G. Robert-Demolaize    -    AB/ABP'
 1068       write(outlun,*) '          T. Weiler              -    AB/ABP'
 1069       write(outlun,*)
 1070       write(outlun,*) '                 CERN 2001 - 2007'
 1071       write(outlun,*)
 1072       write(outlun,*) '         -------------------------------'
 1073       write(outlun,*)
 1074       write(outlun,*)
 1075 !
 1076       write(*,*)
 1077       write(*,*) 'Collimation version of Sixtrack running... 10/2005'
 1078       write(*,*)
 1079       write(*,*) '                     R. Assmann, F. Schmidt, CERN'
 1080       write(*,*) '                           S. Redaelli,      CERN'
 1081       write(*,*) '                       G. Robert-Demolaize,  CERN'
 1082       write(*,*)
 1083       write(*,*) 'Generating particle distribution at FIRST element!'
 1084       write(*,*) 'Optical functions obtained from Sixtrack internal!'
 1085       write(*,*) 'Emittance and energy obtained from Sixtrack input!'
 1086       write(*,*)
 1087       write(*,*)
 1088       write(*,*) 'Info: Betax0   [m]    ', tbetax(1)
 1089       write(*,*) 'Info: Betay0   [m]    ', tbetay(1)
 1090       write(*,*) 'Info: Alphax0         ', talphax(1)
 1091       write(*,*) 'Info: Alphay0         ', talphay(1)
 1092       write(*,*) 'Info: Orbitx0  [mm]   ', torbx(1)
 1093       write(*,*) 'Info: Orbitxp0 [mrad] ', torbxp(1)
 1094       write(*,*) 'Info: Orbity0  [mm]   ', torby(1)
 1095       write(*,*) 'Info: Orbitpy0 [mrad] ', torbyp(1)
 1096       write(*,*) 'Info: Emitx0   [um]   ', remitx
 1097       write(*,*) 'Info: Emity0   [um]   ', remity
 1098       write(*,*) 'Info: E0       [MeV]  ', e0
 1099       write(*,*)
 1100       write(*,*)  'MYENOM' ,myenom
 1101 !
 1102       myemitx0 = remitx*1d-6
 1103       myemity0 = remity*1d-6
 1104       myalphax = talphax(1)
 1105       myalphay = talphay(1)
 1106       mybetax  = tbetax(1)
 1107       mybetay  = tbetay(1)
 1108 !      myenom   = e0
 1109 !
 1110       if (myemitx0.le.0. .or. myemity0.le.0.) then
 1111         write(*,*)                                                      &
 1112      &'ERR> Please use BEAM command to define emittances!'
 1113         stop
 1114       endif
 1115 !
 1116 !++  Calculate the gammas
 1117 !
 1118       mygammax = (1d0+myalphax**2)/mybetax
 1119       mygammay = (1d0+myalphay**2)/mybetay
 1120 !
 1121 !++  Number of points and generate distribution
 1122 !
 1123 !GRD SEMI-AUTOMATIC INPUT
 1124 !      NLOOP=10
 1125 !      MYNEX=6.003
 1126 !      MYDEX=0.0015
 1127 !      MYNEY=6.003
 1128 !      MYDEY=0.0015
 1129 !      DO_COLL=1
 1130 !      NSIG_PRIM=5.
 1131 !      NSIG_SEC=6.
 1132       rselect=64
 1133 !
 1134       write(*,*) 'INFO>  NLOOP     = ', nloop
 1135       write(*,*) 'INFO>  DO_THISDIS     = ', do_thisdis
 1136       write(*,*) 'INFO>  MYNEX     = ', mynex
 1137       write(*,*) 'INFO>  MYDEX     = ', mdex
 1138       write(*,*) 'INFO>  MYNEY     = ', myney
 1139       write(*,*) 'INFO>  MYDEY     = ', mdey
 1140       write(*,*) 'INFO>  FILENAME_DIS     = ', filename_dis
 1141       write(*,*) 'INFO>  ENERROR     = ', enerror
 1142       write(*,*) 'INFO>  BUNCHLENGTH     = ', bunchlength
 1143       write(*,*) 'INFO>  RSELECT   = ', int(rselect)
 1144       write(*,*) 'INFO>  DO_COLL   = ', do_coll
 1145       write(*,*) 'INFO>  DO_NSIG   = ', do_nsig
 1146       write(*,*) 'INFO>  NSIG_TCP3    = ', nsig_tcp3
 1147       write(*,*) 'INFO>  NSIG_TCSG3   = ', nsig_tcsg3
 1148       write(*,*) 'INFO>  NSIG_TCSM3   = ', nsig_tcsm3
 1149       write(*,*) 'INFO>  NSIG_TCLA3   = ', nsig_tcla3
 1150       write(*,*) 'INFO>  NSIG_TCP7    = ', nsig_tcp7
 1151       write(*,*) 'INFO>  NSIG_TCSG7   = ', nsig_tcsg7
 1152       write(*,*) 'INFO>  NSIG_TCSM7   = ', nsig_tcsm7
 1153       write(*,*) 'INFO>  NSIG_TCLA7   = ', nsig_tcla7
 1154       write(*,*) 'INFO>  NSIG_TCLP    = ', nsig_tclp
 1155       write(*,*) 'INFO>  NSIG_TCLI    = ', nsig_tcli
 1156 !      write(*,*) 'INFO>  NSIG_TCTH    = ', nsig_tcth
 1157 !      write(*,*) 'INFO>  NSIG_TCTV    = ', nsig_tctv
 1158       write(*,*) 'INFO>  NSIG_TCTH1   = ', nsig_tcth1
 1159       write(*,*) 'INFO>  NSIG_TCTV1   = ', nsig_tctv1
 1160       write(*,*) 'INFO>  NSIG_TCTH2   = ', nsig_tcth2
 1161       write(*,*) 'INFO>  NSIG_TCTV2   = ', nsig_tctv2
 1162       write(*,*) 'INFO>  NSIG_TCTH5   = ', nsig_tcth5
 1163       write(*,*) 'INFO>  NSIG_TCTV5   = ', nsig_tctv5
 1164       write(*,*) 'INFO>  NSIG_TCTH8   = ', nsig_tcth8
 1165       write(*,*) 'INFO>  NSIG_TCTV8   = ', nsig_tctv8
 1166 !
 1167       write(*,*) 'INFO>  NSIG_TCDQ    = ', nsig_tcdq
 1168       write(*,*) 'INFO>  NSIG_TCSTCDQ = ', nsig_tcstcdq
 1169       write(*,*) 'INFO>  NSIG_TDI     = ', nsig_tdi
 1170       write(*,*) 'INFO>  NSIG_TCXRP   = ', nsig_tcxrp
 1171       write(*,*) 'INFO>  NSIG_TCRYP   = ', nsig_tcryo
 1172       write(*,*) 'INFO>  NSIG_CRY   = ', nsig_cry
 1173 !
 1174       write(*,*)
 1175       write(*,*) 'INFO> INPUT PARAMETERS FOR THE SLICING:'
 1176       write(*,*)
 1177       write(*,*) 'INFO>  N_SLICES    = ', n_slices
 1178       write(*,*) 'INFO>  SMIN_SLICES = ',smin_slices
 1179       write(*,*) 'INFO>  SMAX_SLICES = ',smax_slices
 1180       write(*,*) 'INFO>  RECENTER1   = ',recenter1
 1181       write(*,*) 'INFO>  RECENTER2   = ',recenter2
 1182       write(*,*)
 1183       write(*,*) 'INFO>  FIT1_1   = ',fit1_1
 1184       write(*,*) 'INFO>  FIT1_2   = ',fit1_2
 1185       write(*,*) 'INFO>  FIT1_3   = ',fit1_3
 1186       write(*,*) 'INFO>  FIT1_4   = ',fit1_4
 1187       write(*,*) 'INFO>  FIT1_5   = ',fit1_5
 1188       write(*,*) 'INFO>  FIT1_6   = ',fit1_6
 1189       write(*,*) 'INFO>  SCALING1 = ',ssf1
 1190       write(*,*)
 1191       write(*,*) 'INFO>  FIT2_1   = ',fit2_1
 1192       write(*,*) 'INFO>  FIT2_2   = ',fit2_2
 1193       write(*,*) 'INFO>  FIT2_3   = ',fit2_3
 1194       write(*,*) 'INFO>  FIT2_4   = ',fit2_4
 1195       write(*,*) 'INFO>  FIT2_5   = ',fit2_5
 1196       write(*,*) 'INFO>  FIT2_6   = ',fit2_6
 1197       write(*,*) 'INFO>  SCALING2 = ',ssf2
 1198       write(*,*)
 1199 !
 1200 ! HERE WE CHECK IF THE NEW INPUT IS READ CORRECTLY
 1201 !
 1202       write(*,*) 'INFO>  EMITX0            = ', emitx0
 1203       write(*,*) 'INFO>  EMITY0            = ', emity0
 1204       write(*,*)
 1205       write(*,*) 'INFO>  DO_SELECT         = ', do_select
 1206       write(*,*) 'INFO>  DO_NOMINAL        = ', do_nominal
 1207       write(*,*) 'INFO>  RND_SEED          = ', rnd_seed
 1208       write(*,*) 'INFO>  DOWRITE_DIST      = ', dowrite_dist
 1209       write(*,*) 'INFO>  NAME_SEL          = ', name_sel
 1210       write(*,*) 'INFO>  DO_ONESIDE        = ', do_oneside
 1211       write(*,*) 'INFO>  DOWRITE_IMPACT    = ', dowrite_impact
 1212       write(*,*) 'INFO>  DOWRITE_SECONDARY = ', dowrite_secondary
 1213       write(*,*) 'INFO>  DOWRITE_AMPLITUDE = ', dowrite_amplitude
 1214       write(*,*)
 1215       write(*,*) 'INFO>  XBEAT             = ', xbeat
 1216       write(*,*) 'INFO>  XBEATPHASE        = ', xbeatphase
 1217       write(*,*) 'INFO>  YBEAT             = ', ybeat
 1218       write(*,*) 'INFO>  YBEATPHASE        = ', ybeatphase
 1219       write(*,*)
 1220       write(*,*) 'INFO>  C_RMSTILT_PRIM     = ', c_rmstilt_prim
 1221       write(*,*) 'INFO>  C_RMSTILT_SEC      = ', c_rmstilt_sec
 1222       write(*,*) 'INFO>  C_SYSTILT_PRIM     = ', c_systilt_prim
 1223       write(*,*) 'INFO>  C_SYSTILT_SEC      = ', c_systilt_sec
 1224       write(*,*) 'INFO>  C_RMSOFFSET_PRIM   = ', c_rmsoffset_prim
 1225       write(*,*) 'INFO>  C_SYSOFFSET_PRIM   = ', c_sysoffset_prim
 1226       write(*,*) 'INFO>  C_RMSOFFSET_SEC    = ', c_rmsoffset_sec
 1227       write(*,*) 'INFO>  C_SYSOFFSET_SEC    = ', c_sysoffset_sec
 1228       write(*,*) 'INFO>  C_OFFSETTITLT_SEED = ', c_offsettilt_seed
 1229       write(*,*) 'INFO>  C_RMSERROR_GAP     = ', c_rmserror_gap
 1230       write(*,*) 'INFO>  DO_MINGAP          = ', do_mingap
 1231       write(*,*)
 1232       write(*,*) 'INFO>  RADIAL            = ', radial
 1233       write(*,*) 'INFO>  NR                = ', nr
 1234       write(*,*) 'INFO>  NDR               = ', ndr
 1235       write(*,*)
 1236       write(*,*) 'INFO>  DRIFTSX           = ', driftsx
 1237       write(*,*) 'INFO>  DRIFTSY           = ', driftsy
 1238       write(*,*) 'INFO>  CUT_INPUT         = ', cut_input
 1239       write(*,*) 'INFO>  SYSTILT_ANTISYMM  = ', systilt_antisymm
 1240       write(*,*)
 1241       write(*,*) 'INFO>  IPENCIL           = ', ipencil
 1242       write(*,*) 'INFO>  PENCIL_OFFSET     = ', pencil_offset
 1243       write(*,*) 'INFO>  PENCIL_RMSX       = ', pencil_rmsx
 1244       write(*,*) 'INFO>  PENCIL_RMSY       = ', pencil_rmsy
 1245       write(*,*) 'INFO>  PENCIL_DISTR      = ', pencil_distr
 1246       write(*,*)
 1247       write(*,*) 'INFO>  COLL_DB           = ', coll_db
 1248       write(*,*) 'INFO>  IBEAM             = ', ibeam
 1249       write(*,*)
 1250       write(*,*) 'INFO>  DOWRITETRACKS     = ', dowritetracks
 1251       write(*,*)
 1252       write(*,*) 'INFO>  CERN              = ', cern
 1253       write(*,*)
 1254       write(*,*) 'INFO>  CASTORDIR     = ', castordir
 1255       write(*,*)
 1256       write(*,*) 'INFO>  JOBNUMBER     = ', jobnumber
 1257       write(*,*)
 1258       write(*,*) 'INFO>  CUTS     = ', sigsecut2, sigsecut3
 1259       write(*,*)
 1260 !
 1261       mynp = nloop*napx
 1262 !
 1263       napx00 = napx
 1264 !
 1265       write(*,*) 'INFO>  NAPX     = ', napx, mynp
 1266       write(*,*) 'INFO>  Sigma_x0 = ', sqrt(mybetax*myemitx0)
 1267       write(*,*) 'INFO>  Sigma_y0 = ', sqrt(mybetay*myemity0)
 1268 !
 1269 ! HERE WE SET THE MARKER FOR INITIALIZATION:
 1270 !
 1271       firstrun = .true.
 1272 !
 1273 ! ...and here is implemented colltrack's beam distribution:
 1274 !
 1275 !
 1276 !++  Initialize random number generator
 1277 !
 1278         if (rnd_seed.eq.0) rnd_seed = mclock_liar()
 1279         if (rnd_seed.lt.0) rnd_seed = abs(rnd_seed)
 1280         rnd_lux = 3
 1281         rnd_k1  = 0
 1282         rnd_k2  = 0
 1283         call rluxgo(rnd_lux, rnd_seed, rnd_k1, rnd_k2)
 1284         CALL RNDMST(12,34,56,78)
 1285         write(*,*)
 1286         write(outlun,*) 'INFO>  rnd_seed: ', rnd_seed
 1287 !Call distribution routines only if collimation block is in fort.3, otherwise
 1288 !the standard sixtrack would be prevented by the 'stop' command
 1289       if(do_coll) then
 1290       if (radial) then
 1291          call   makedis_radial(mynp, myalphax, myalphay, mybetax,
 1292      &        mybetay, myemitx0, myemity0, myenom, nr, ndr,
 1293      &        myx, myxp, myy, myyp, myp, mys)
 1294       else
 1295          if (do_thisdis.eq.1) then
 1296             call makedis(mynp, myalphax, myalphay, mybetax, mybetay,
 1297      &           myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
 1298      &           myx, myxp, myy, myyp, myp, mys)
 1299          elseif(do_thisdis.eq.2) then
 1300             call makedis_st(mynp, myalphax, myalphay, mybetax, mybetay,
 1301      &           myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
 1302      &           myx, myxp, myy, myyp, myp, mys)
 1303          elseif(do_thisdis.eq.3) then
 1304             call makedis_de(mynp, myalphax, myalphay, mybetax, mybetay,
 1305      &           myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,
 1306      &           myx, myxp, myy, myyp, myp, mys,enerror,bunchlength)
 1307          elseif(do_thisdis.eq.4) then
 1308             call  readdis(filename_dis,
 1309      &           mynp, myx, myxp, myy, myyp, myp, mys)                  
 1310          else
 1311             write(*,*) 'INFO> review your distribution parameters !!'
 1312             stop
 1313          endif
 1314 !    
 1315       endif
 1316 !    
 1317       endif
 1318 !++  Reset distribution for pencil beam
 1319 !
 1320       if (ipencil.gt.0) then
 1321          write(*,*) 'WARN>  Distributions reset to pencil beam!'    
 1322          write(*,*)
 1323          write(outlun,*) 'WARN>  Distributions reset to pencil beam!'    
 1324          do j = 1, mynp
 1325             myx(j)  = 0d0
 1326             myxp(j) = 0d0
 1327             myy(j)  = 0d0
 1328             myyp(j) = 0d0
 1329          end do
 1330       endif
 1331 !
 1332 !++  Optionally write the generated particle distribution
 1333 !
 1334       open(unit=52,file='dist0.dat')
 1335       if (dowrite_dist) then
 1336         write(52,*)"1=x 2=xp 3=y 4=yp 5=s 6=p 7=x_norm 8=xp_norm
 1337      1  9=y_norm 10=yp_norm 11=Ax 12=Ay 13=iname"        
 1338         do j = 1, mynp
 1339          write(52,'(12(1X,E15.7),a)') myx(j), myxp(j), myy(j), myyp(j),
 1340      &     mys(j), myp(j), (myx(j)/sqrt(myemitx0*mybetax)),
 1341      &     (myx(j)*myalphax+myxp(j)*mybetax)/sqrt(myemitx0*mybetax),
 1342      &     (myy(j)/sqrt(myemity0*mybetay)),
 1343      &     (myy(j)*myalphay+myyp(j)*mybetay)/sqrt(myemity0*mybetay),
 1344      &     sqrt(  ((myx(j)/sqrt(myemitx0*mybetax)))**2 +
 1345      & ( (myx(j)*myalphax+myxp(j)*mybetax)/sqrt(myemitx0*mybetax))**2 ),
 1346      &     sqrt( ((myy(j)/sqrt(myemity0*mybetay))  )**2+
 1347      & ( (myy(j)*myalphay+myyp(j)*mybetay)/sqrt(myemity0*mybetay) )**2 )
 1348         end do
 1349       endif
 1350       close(52)
 1351 !
 1352 !++  Initialize efficiency array
 1353 !
 1354       do i = 1, mynp
 1355         part_hit(i)           = 0
 1356         part_abs(i)           = 0
 1357         part_select(i)        = 1
 1358         part_indiv(i)         = -1d-6
 1359         part_linteract(i)     = 0d0
 1360         part_hit_before(i)    = 0
 1361         tertiary(i)           = 0
 1362         secondary(i)          = 0
 1363         other(i)              = 0
 1364         x00(i)      = myx(i)
 1365         xp00(i)     = myxp(i)
 1366         y00(i)      = myy(i)
 1367         yp00(i)     = myyp(i)
 1368       end do
 1369 !
 1370       do i=1,iu
 1371       sum_ax(i)   = 0d0
 1372       sqsum_ax(i) = 0d0
 1373       sum_ay(i)   = 0d0
 1374       sqsum_ay(i) = 0d0
 1375       nampl(i)    = 0d0
 1376       sampl(i)    = 0d0
 1377       end do
 1378 !
 1379       nspx = 0d0
 1380       nspy = 0d0
 1381
 1382       np0  = mynp
 1383 !
 1384       ax0  = myalphax
 1385       bx0  = mybetax
 1386       mux0 = mux(1)
 1387       ay0  = myalphay
 1388       by0  = mybetay
 1389       muy0 = muy(1)
 1390       iturn = 1
 1391       ie    = 1
 1392       n_tot_absorbed = 0
 1393 !
 1394 !===============================================================================
 1395 !Ralph make loop over 1e6/napx, a read xv(1,j) etc
 1396 !Du solltest zur Sicherheit dies resetten bevor Du in thin6d gehst
 1397 !Im Falle von Teilchenverluste werden n mlich pstop und nnumxv umgesetzt
 1398 !      do 80 i=1,npart
 1399 !        pstop(i)=.false.
 1400 !        nnumxv(i)=numl
 1401 !   80 numxv(i)=numl
 1402 !===============================================================================
 1403
 1404
 1405       open(unit=42, file='beta_beat.dat')
 1406       write(42,*)                                                       &
 1407      &'# 1=s 2=bx/bx0 3=by/by0 4=sigx0 5=sigy0 6=crot 7=acalc'
 1408       write(42,*) j
 1409
 1410       open(unit=43, file='collgaps.dat')
 1411       
 1412       open(unit=44, file='survival.dat')
 1413       write(44,*)                                                       &
 1414      &'# 1=turn 2=n_particle 3=sample_number'
 1415 !
 1416       open(unit=40, file='collimator-temp.db')
 1417       if(firstrun) write(43,*)                                          &
 1418      &'# ID name  angle[rad]  betax[m]  betay[m] ',                     &
 1419      &'halfgap[m]  Material  Length[m]  sigx[m]  sigy[m] ',             &
 1420      &'tilt1[rad] tilt2[rad] nsig'
 1421
 1422       open(unit=55, file='collsettings.dat')
 1423       if(firstrun) write(55,*)                                          &
 1424      &'# name  slicenumber  halfgap[m]  gap_offset[m] ',                &
 1425      &'tilt jaw1[rad]  tilt jaw2[rad] length[m] material'               &
 1426
 1427       if (dowrite_impact) then
 1428         open(unit=49,file='impact.dat')
 1429       if(firstrun)  write(49,*)                                         &
 1430      &'# 1=impact 2=divergence'
 1431       endif
 1432
 1433 !SEPT 2007 valentina : open (if set write_c_out) special outputs for crystal
 1434       if (write_c_out)  then
 1435         OPEN(UNIT=881,FILE='cry_entrance.dat')
 1436         WRITE(881,'(a)')
 1437      1  '# ipart nturn last_proc icoll coll_mat   x[m]         xp[rad]
 1438      2       y[m]             yp[rad]       p[GeV]'
 1439 c
 1440         OPEN(UNIT=882,FILE='cry_exit.dat')
 1441         WRITE(882,'(a)')
 1442      1  '#ipart nturn last_proc proc  icoll   coll_mat     x[m]        
 1443      2xp[rad]        y[m]           yp[rad]       p[GeV]'
 1444 c
 1445         OPEN(UNIT=883,FILE='cry_entrance_norm.dat')
 1446         WRITE(883,'(a)')
 1447      1  '#ipart nturn last_proc icoll coll_mat   x[m]         xp[rad]  
 1448      2      y[m]         yp[rad]          n_ampl-X[sig]    n_ampl-Y[sig]
 1449      3  p[GeV]'
 1450
 1451         OPEN(UNIT=884,FILE='cry_exit_norm.dat')
 1452         WRITE(884,'(a)')
 1453      1  '#ipart interaction? last_proc proc nturn icoll coll_mat    x[m]
 1454      2       xp[rad]       y[m]           yp[rad]          n_ampl-X[sig]
 1455      3    n_ampl-Y[sig]      p[GeV]'
 1456 !
 1457         OPEN(UNIT=885,FILE='kick.dat')
 1458         write(885,'(a)')
 1459      & '#1=ipart 2=nturn 3=last_proc 4=proc 5=icoll 6=coll_mat  7=x[m]
 1460      & 8=xp[rad]  9=y[m] 10=yp[rad] 11=kickx[rad] 12=kicky[rad]
 1461      & 13=Deltap[GeV] 14=aperture 15=tilt '
 1462 !
 1463         OPEN(UNIT=833,FILE='cr_par_check.dat')        
 1464         open(unit=866,file='cr_process.dat')
 1465 c        open(unit=9999,file='debug.dat')
 1466
 1467       endif
 1468
 1469 c#########################################################################
 1470 C   beginning of the loop on the particle samples (closes @~1820)
 1471 c########################################################################      
 1472       
 1473       do j = 1, int(mynp/napx00)
 1474 !
 1475             write(*,*) 'Sample number ', j, int(mynp/napx00)
 1476             samplenumber=j
 1477 !
 1478 !
 1479 ! HERE WE OPEN ALL THE NEEDED OUTPUT FILES
 1480 !
 1481 ! TW06/08 added ouputfile for real collimator settings (incluing slicing, ...)
 1482 ! TW06/08
 1483 !
 1484 !APRIL2005
 1485 c---------------      
 1486       if (dowritetracks) then
 1487 c              
 1488        if (cern) then
 1489         pfile(1:8) = 'tracks2.'
 1490 c        
 1491         if(samplenumber.le.9) then
 1492            pfile(9:9) = smpl
 1493            pfile(10:13) = '.dat'
 1494         elseif(samplenumber.gt.9.and.samplenumber.le.99) then
 1495            pfile(9:10) = smpl
 1496            pfile(11:14) = '.dat'
 1497         elseif(samplenumber.gt.99.and.                                  &
 1498      &samplenumber.le.int(mynp/napx00)) then
 1499            pfile(9:11) = smpl
 1500            pfile(12:15) = '.dat'
 1501         endif
 1502 c        
 1503         if(samplenumber.le.9)                                           &
 1504      &open(unit=38,file=pfile(1:13))
 1505         if(samplenumber.gt.9.and.samplenumber.le.99)                    &
 1506      &open(unit=38,file=pfile(1:14))
 1507 c        
 1508         if(samplenumber.gt.99.and.                                      &
 1509      &samplenumber.le.int(mynp/napx00))                                 &
 1510      &open(unit=38,file=pfile(1:15))
 1511         else
 1512         open(unit=38,file='tracks2.dat')
 1513 !
 1514         endif !close if(cern)
 1515 c        
 1516         if(firstrun) write(38,*)                                        &
 1517      &'# 1=name 2=turn 3=s 4=x 5=xp 6=y 7=yp 8=DE/E 9=type'
 1518 c        
 1519        endif   !close if(dowritetracks)
 1520       
 1521 c        
 1522 !AUGUST2006:write pencul sheet beam coordiantes to file ---- TW
 1523       open(unit=9997, file='pencilbeam_distr.dat')
 1524       if(firstrun) write(9997,*) 'x    xp    y      yp'      
 1525        if(do_select) then
 1526          open(unit=45, file='coll_ellipse.dat')
 1527          if (firstrun) then
 1528            write(45,'(a)')                                               &
 1529      &          '#  1=x 2=y 3=xp 4=yp 5=E 6=s 7=turn 8=xnorm 9=ynorm    &
 1530      &    10=xpnorm 11=xpnorm 12=ampl_x 13=ampl_y'  
 1531 c           write(9999,'(a)')                                               &
 1532 c     &          '#  1=x 2=y 3=xp 4=yp 5=E 6=s 7=turn 8=xnorm 9=ynorm    &
 1533 c     &    10=xpnorm 11=xpnorm 12=ampl_x 13=ampl_y'  
 1534          endif
 1535        endif
 1536        if(dowrite_impact) then
 1537         open(unit=46, file='all_impacts.dat')
 1538         open(unit=47, file='all_absorptions.dat')
 1539         open(unit=48, file='FLUKA_impacts.dat')
 1540         open(unit=39, file='FirstImpacts.dat')
 1541         if (firstrun) then
 1542           write(46,'(a)') '# 1=name 2=turn 3=s'
 1543           write(47,'(a)') '# 1=name 2=turn 3=s'
 1544           write(48,'(a)')                                               &
 1545      &'# 1=icoll 2=c_rotation 3=s 4=x 5=xp 6=y 7=yp 8=nabs 9=np 10=turn'
 1546           write(39,*)                                                   &
 1547      &     '%1=name,2=iturn, 3=icoll, 4=nabs, 5=s_imp[m], 6=s_out[m], ',&
 1548      &     '7=x_in(b!)[m], 8=xp_in, 9=y_in, 10=yp_in, ',                &
 1549      &     '11=x_out [m], 12=xp_out, 13=y_out, 14=yp_out'
 1550           write(866,'(a)')                                               &
 1551      &     '%1=name,2=iturn, 3=icoll, 4=cr_process'
 1552        endif
 1553       endif
 1554       if(name_sel(1:3).eq.'COL') then
 1555       open(unit=555, file='RHIClosses.dat')
 1556       if(firstrun) write(555,'(a)')                                     &
 1557      &'# 1=name 2=turn 3=s 4=x 5=xp 6=y 7=yp 8=dp/p 9=type'
 1558       endif
 1559 !
 1560 !FOR FAST TRACKING CHECKS AND MULTIPLE SAMPLES
 1561 !       open(unit=999,file='checkturns.dat')
 1562 !
 1563 !++  Reset this as advised by Frank
 1564 !
 1565 !            do 80 i=1,npart
 1566 !              pstop(i)=.false.
 1567 !              nnumxv(i)=numl
 1568 !   80       numxv(i)=numl
 1569 !
 1570 !++  Copy new particles to tracking arrays. Also add the orbit offset at
 1571 !++  start of ring!
 1572 !
 1573             do i = 1, napx00
 1574               xv(1,i)  = 1e3*myx(i+(j-1)*napx00)  +torbx(1)
 1575               yv(1,i)  = 1e3*myxp(i+(j-1)*napx00) +torbxp(1)
 1576               xv(2,i)  = 1e3*myy(i+(j-1)*napx00)  +torby(1)
 1577               yv(2,i)  = 1e3*myyp(i+(j-1)*napx00) +torbyp(1)
 1578               x00(i)  = xv(1,i)
 1579               xp00(i) = yv(1,i)
 1580               y00(i)  = xv(2,i)
 1581               yp00(i) = yv(2,i)
 1582 !JULY2005 assignation of the proper bunch length
 1583               sigmv(i) = mys(i+(j-1)*napx00)
 1584               ejv(i)   = myp(i+(j-1)*napx00)
 1585 !
 1586 !GRD FOR NOT FAST TRACKING ONLY
 1587               ejfv(i)=sqrt(ejv(i)*ejv(i)-pma*pma)
 1588               rvv(j)=(ejv(i)*e0f)/(e0*ejfv(i))
 1589               dpsv(i)=(ejfv(i)-e0f)/e0f
 1590               oidpsv(i)=one/(one+dpsv(i))
 1591               dpsv1(i)=dpsv(i)*c1e3*oidpsv(i)
 1592 !GRD
 1593 !APRIL2005
 1594 !              dpsv(i)  = 0d0
 1595               absorbed(i) = 0
 1596               do ieff =1, numeff
 1597                  counted_r(i,ieff) = 0
 1598                  counted_x(i,ieff) = 0
 1599                  counted_y(i,ieff) = 0
 1600               end do
 1601 !GRD INITIALIZE MAX COUNTERS
 1602               ieffmax_r(i) = 0
 1603               ieffmax_x(i) = 0
 1604               ieffmax_y(i) = 0
 1605             end do
 1606 !
 1607 !
 1608 !++  Thin lens tracking
 1609 !
 1610 !
 1611           call thin6d(nthinerr)
 1612 !
 1613 !
 1614       if(dowritetracks) then
 1615        if(cern) close(38)
 1616       endif
 1617 !------------------------------------------------------------------------
 1618 !++  Write the number of absorbed particles
 1619 !
 1620       write(outlun,*) 'INFO>  Number of impacts             : ',        &
 1621 !     &N_TOT_ABSORBED+NSURVIVE
 1622      &n_tot_absorbed+nsurvive_end
 1623       write(outlun,*) 'INFO>  Number of impacts at selected : ',        &
 1624      &num_selhit
 1625       write(outlun,*) 'INFO>  Number of surviving particles : ',        &
 1626 !     &NSURVIVE
 1627      &nsurvive_end
 1628       write(outlun,*) 'INFO>  Number of absorbed particles  : ',        &
 1629      &n_tot_absorbed
 1630 !
 1631       write(outlun,*)
 1632 !GRD UPGRADE JANUARY 2005
 1633       if(n_tot_absorbed.ne.0d0) then
 1634 !
 1635       write(outlun,*) ' INFO>  Eff_r @  8 sigma    [e-4] : ',           &
 1636      &neff(5)/dble(n_tot_absorbed)/1d-4
 1637       write(outlun,*) ' INFO>  Eff_r @ 10 sigma    [e-4] : ',           &
 1638      &neff(9)/dble(n_tot_absorbed)/1d-4
 1639       write(outlun,*) ' INFO>  Eff_r @ 10-20 sigma [e-4] : ',           &
 1640      &(neff(9)-neff(19))/(dble(n_tot_absorbed))/1d-4
 1641 !
 1642       write(outlun,*)
 1643       write(outlun,*) neff(5)/dble(n_tot_absorbed),                     &
 1644      &neff(9)/dble(n_tot_absorbed),                                     &
 1645      &(neff(9)-neff(19))/(dble(n_tot_absorbed)), ' !eff'
 1646       write(outlun,*)
 1647 !
 1648 !UPGRADE JANUARY 2005
 1649       else
 1650           write(*,*) 'NO PARTICLE ABSORBED'
 1651       endif
 1652 !
 1653 !----
 1654       write(*,*)
 1655       write(*,*) 'INFO>  Number of impacts             : ',             &
 1656      &n_tot_absorbed+nsurvive_end
 1657       write(*,*) 'INFO>  Number of impacts at selected : ',             &
 1658      &num_selhit
 1659       write(*,*) 'INFO>  Number of surviving particles : ',             &
 1660      &nsurvive_end
 1661       write(*,*) 'INFO>  Number of absorbed particles  : ',             &
 1662      &n_tot_absorbed
 1663       write(*,*)
 1664       if(n_tot_absorbed.ne.0d0) then
 1665       write(*,*) ' INFO>  Eff_r @  8 sigma    [e-4] : ',                &
 1666      &neff(5)/dble(n_tot_absorbed)/1d-4
 1667       write(*,*) ' INFO>  Eff_r @ 10 sigma    [e-4] : ',                &
 1668      &neff(9)/dble(n_tot_absorbed)/1d-4
 1669       write(*,*) ' INFO>  Eff_r @ 10-20 sigma [e-4] : ',                &
 1670      &(neff(9)-neff(19))/(dble(n_tot_absorbed))/1d-4
 1671       write(*,*)
 1672       else
 1673           write(*,*) 'NO PARTICLE ABSORBED'
 1674       endif
 1675 !
 1676 !********************************************************************
 1677 ! THIS IS THE END OF THE 'DO' LOOP OVER THE thin6d SUBROUTINE  !!!!!
 1678 !********************************************************************
 1679       end do
 1680 !
 1681 !------------------------------------------------------------------------
 1682 !++  Write efficiency file
 1683 !
 1684       open(unit=99, file='efficiency.dat')
 1685       if(n_tot_absorbed.ne.0d0) then
 1686       write(99,*)                                                       &
 1687      &'# 1=rad_sigma 2=frac_x 3=frac_y 4=frac_r'
 1688       do k=1,numeff
 1689         write(99,'(7(1x,e15.7),1x,I5)') rsig(k),                        &
 1690      &neffx(k)/dble(n_tot_absorbed),                                    &
 1691      &neffy(k)/dble(n_tot_absorbed),                                    &
 1692      &neff(k)/dble(n_tot_absorbed),                                     &
 1693      &neffx(k),                                                         &
 1694      &neffy(k),                                                         &
 1695      &neff(k), n_tot_absorbed
 1696       end do
 1697       else
 1698           write(*,*) 'NO PARTICLE ABSORBED'
 1699       endif
 1700       close(99)
 1701 !------------------------------------------------------------------------
 1702 !++  Write collimation summary file
 1703 !
 1704       open(unit=50, file='coll_summary.dat')
 1705       
 1706       write(50,*)                                                       &
 1707      &'# 1=icoll 2=nimp 3=nabs 4=imp_av 5=imp_sig 6=length'
 1708       do icoll = 1, db_ncoll
 1709         if(db_length(icoll).gt.0d0) then
 1710         write(50,'(i4,1x,a,2(1x,i5),2(1x,e15.7),3x,f13.10)')            &
 1711      &icoll, db_name1(icoll),cn_impact(icoll), cn_absorbed(icoll),      &
 1712      &caverage(icoll), csigma(icoll),db_length(icoll)
 1713       endif
 1714       end do
 1715       close(50)
 1716 !-------------------------------------------------------------------------
 1717 !GRD
 1718       close(outlun)
 1719       close(40)
 1720       close(42)
 1721       close(43)
 1722       close(44)
 1723       if(dowrite_impact) close(49)
 1724 !SEPT2008 valentina: close special cry outputs
 1725 c      close(9999) !close the debug file
 1726       if (write_c_out) then
 1727       CLOSE(881)   !valentina
 1728       CLOSE(882)   !valentina
 1729       CLOSE(883)   !valentina
 1730       CLOSE(884)   !valentina
 1731       CLOSE(885)   !valentina
 1732       close(833)
 1733       endif
 1734
 1735       if(dowritetracks) then
 1736       if(.not. cern) close(38)
 1737       if(name_sel(1:3).eq.'COL') close(555)
 1738
 1739       endif
 1740
 1741       if(do_select) then
 1742          close(45)
 1743       endif
 1744       if(dowrite_impact) then
 1745         close(46)
 1746         close(46)
 1747         close(47)
 1748         close(48)
 1749         close(39)
 1750         
 1751         close(866)
 1752       endif
 1753 !
 1754 !
 1755 !++  End of Ralph's own little loop
 1756 !
 1757 !=============================================================================
 1758         endif
 1759       endif
 1760 !
 1761       open(unit=56, file='amplitude.dat')
 1762       open(unit=51, file='amplitude2.dat')
 1763       open(unit=57, file='betafunctions.dat')
 1764       
 1765       if(dowrite_amplitude) then
 1766       write(56,*)                                                       &
 1767      &'# 1=ielem 2=name 3=s 4=AX_AV 5=AX_RMS 6=AY_AV 7=AY_RMS',         &
 1768      &'8=alphax 9=alphay 10=betax 11=betay 12=orbitx',                  &
 1769      &'13=orbity 14=tdispx 15=tdispy',                                  &
 1770      &'16=xbob 17=ybob 18=xpbob 19=ypbob'
 1771       do i=1,iu
 1772         write(56,'(i4, (1x,a16), 17(1x,e20.13))')                       &
 1773      &i, ename(i), sampl(i),                                            &
 1774      &sum_ax(i)/max(nampl(i),1),                                        &
 1775      &sqrt(abs((sqsum_ax(i)/max(nampl(i),1))-                           &
 1776      &(sum_ax(i)/max(nampl(i),1))**2)),                                 &
 1777      &sum_ay(i)/max(nampl(i),1),                                        &
 1778      &sqrt(abs((sqsum_ay(i)/max(nampl(i),1))-                           &
 1779      &(sum_ay(i)/max(nampl(i),1))**2)),                                 &
 1780      &talphax(i), talphay(i),                                           &
 1781      &tbetax(i), tbetay(i), torbx(i), torby(i),                         &
 1782      &tdispx(i), tdispy(i),                                             &
 1783      &xbob(i),ybob(i),xpbob(i),ypbob(i)
 1784       end do
 1785       write(51,*)                                                       &
 1786      &'# 1=ielem 2=name 3=s 4=ORBITX 5=orbity 6=orbxp 7=orbyp 8=tdispx 9
 1787      &=tdispy 10=x_norm 11=y_norm 12=xp_norm 13=yp_norm 14=nx 15=ny'
 1788       
 1789       do i=1,iu
 1790         write(51,*)                        
 1791      &i, ename(i), sampl(i),                                            &
 1792      &torbx(i), torby(i),        
 1793      &torbxp(i),torbyp(i),
 1794      &tdispx(i), tdispy(i),                                             &
 1795      &xdebugN(i),ydebugN(i),xpdebugN(i),ypdebugN(i),
 1796      &sqrt(xdebugN(i)**2+xpdebugN(i)**2),
 1797      &sqrt(ydebugN(i)**2+ypdebugN(i)**2)
 1798         
 1799       end do
 1800       
 1801       write(57,*)                                                       &
 1802      &'# 1=ielem 2=name 3=s 4=TBETAX 5=TBETAY'
 1803       do i=1,iu
 1804         write(57,'(i4, (1x,a16), 3(1x,e15.7))')                         &
 1805      &i, ename(i), sampl(i),                                            &
 1806      &tbetax(i), tbetay(i)
 1807       end do
 1808       endif
 1809       close(56)
 1810       close(51)
 1811       close(57)
 1812       open(unit=99, file='orbitchecking.dat')
 1813       write(99,*) '# 1=s 2=torbitx 3=torbity'
 1814       do j=1,iu
 1815       write(99,'(i4, 3(1x,e15.7))')                                     &
 1816      &j, sampl(j),torbx(j), torby(j)
 1817       end do
 1818       close(99)
 1819       return
 1820       end
 1821       subroutine thin4d(nthinerr)
 1822 !-----------------------------------------------------------------------
 1823 !
 1824 !  TRACK THIN LENS 4D
 1825 !
 1826 !
 1827 !  F. SCHMIDT
 1828 !-----------------------------------------------------------------------
 1829       implicit none
 1830       integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
 1831       double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
 1832      &crxb,crzb,dpsv3,pux,r0,r2b,rb,rho2b,rkb,stracki,tkb,xbb,xlvj,xrb, &
 1833      &yv1j,yv2j,zbb,zlvj,zrb
 1834       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 1835      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 1836      &nrco,ntr,nzfz
 1837       parameter(npart = 64,nmac = 1)
 1838       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 1839      &nzfz = 300000,mmul = 11)
 1840       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 1841      &nema = 15)
 1842       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 1843       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 1844       parameter(nmon1 = 600,ncor1 = 600)
 1845       parameter(ntr = 20,nbb = 160)
 1846       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
 1847       double precision e0fo,e0o,xv1j,xv2j
 1848       double precision acdipamp, qd, acphase, acdipamp2,                &
 1849      &acdipamp1
 1850       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
 1851       logical llost
 1852       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 1853      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 1854      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 1855      &one,pieni,pmae,pmap,three,two,zero
 1856       parameter(pieni = 1d-38)
 1857       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 1858       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 1859       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 1860       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 1861       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 1862      &1.0d16)
 1863       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 1864       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 1865       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 1866       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 1867       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 1868       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 1869       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 1870       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 1871       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 1872      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 1873      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 1874      &imc,imtr,iorg,iout,                                               &
 1875      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 1876      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 1877      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 1878      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 1879      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 1880      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 1881      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 1882      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 1883      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 1884       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 1885      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 1886      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 1887      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 1888      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 1889      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 1890      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 1891      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 1892      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 1893      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 1894      &acdipph
 1895       real hmal
 1896       character*16 bez,bezb,bezr,erbez,bezl
 1897       character*80 toptit,sixtit,commen
 1898       common/erro/ierro,erbez
 1899       common/kons/pi,pi2,pisqrt,rad
 1900       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 1901       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 1902       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 1903       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 1904       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 1905       common/syos2/rvf(mpa)
 1906       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 1907      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 1908       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 1909      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 1910      &iicav,itionc(nele),ition,idp,ncy,ixcav
 1911       common/corcom/dpscor,sigcor,icode,idam,its6d
 1912       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 1913      &bka(nele,mmul),aka(nele,mmul)
 1914       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 1915       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 1916       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 1917      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 1918       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 1919       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 1920      &iout
 1921       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 1922       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 1923      &ntco,eui,euii,nlin,bezl(nele)
 1924       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 1925      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 1926      &ncororb(nele)
 1927       common/apert/apx(nele),apz(nele),ape(3,nele)
 1928       common/clos/sigma0(2),iclo,ncorru,ncorrep
 1929       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 1930      &ratioe(nele),iratioe(nele),icoe
 1931       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 1932       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 1933       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 1934       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 1935       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 1936      &nstart,nstop,iskip,iconv,imad
 1937       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 1938       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 1939       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 1940       common/ripp2/nrturn
 1941       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 1942       common/pawc/hmal(nplo)
 1943       common/tit/sixtit,commen,ithick
 1944       common/co6d/clo6(3),clop6(3)
 1945       common/dkic/dki(nele,3)
 1946       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 1947      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 1948      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 1949      &nbeam,ibbc,ibeco,ibtyp,lhc
 1950       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 1951       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 1952       common/wireco/ wirel(nele)
 1953       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 1954      &nturn3(nele), nturn4(nele)
 1955       integer idz,itra
 1956       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 1957       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 1958      &dps(mpa),idz(2)
 1959       common/anf/chi0,chid,exz(2,6),dp1,itra
 1960       integer ichrom,is
 1961       double precision alf0,amp,bet0,clo,clop,cro,x,y
 1962       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 1963       common/chrom/cro(2),is(2),ichrom
 1964       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 1965      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 1966       double precision dpmax,preda,weig1,weig2
 1967       character*16 coel
 1968       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 1969       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 1970       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 1971      &coel(10)
 1972       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 1973      &zsi
 1974       real tlim,time0,time1
 1975       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 1976      &aai(nblz,mmul),bbi(nblz,mmul)
 1977       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 1978       common/damp/damp,ampt
 1979       common/ttime/tlim,time0,time1
 1980       double precision tasm
 1981       common/tasm/tasm(6,6)
 1982       integer iv,ixv,nlostp,nms,numxv
 1983       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 1984      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 1985      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 1986      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 1987      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 1988      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 1989      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 1990      &zsiv,zsv
 1991       logical pstop
 1992       common/main1/                                                     &
 1993      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 1994      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 1995      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 1996      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 1997      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 1998      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 1999      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 2000      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 2001       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 2002      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 2003      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 2004      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 2005      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 2006      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 2007      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 2008      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 2009      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 2010       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 2011      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 2012      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 2013      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 2014       integer numx
 2015       double precision e0f
 2016       common/main4/ e0f,numx
 2017       integer ktrack,nwri
 2018       double precision dpsv1,strack,strackc,stracks
 2019       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 2020      &stracks(nblz),dpsv1(npart),nwri
 2021       double precision cc,xlim,ylim
 2022       parameter(cc = 1.12837916709551d0)
 2023       parameter(xlim = 5.33d0)
 2024       parameter(ylim = 4.29d0)
 2025       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
 2026      &r2b(npart),rb(npart),rkb(npart),                                  &
 2027      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
 2028      &crzb(npart),cbxb(npart),cbzb(npart)
 2029       dimension dpsv3(npart)
 2030       save
 2031 !-----------------------------------------------------------------------
 2032       nthinerr=0
 2033       do 640 n=1,numl
 2034         numx=n-1
 2035         if(irip.eq.1) call ripple(n)
 2036         if(mod(numx,nwri).eq.0) call writebin(nthinerr)
 2037         if(nthinerr.ne.0) return
 2038         do 630 i=1,iu
 2039           ix=ic(i)-nblo
 2040 !---------count:43
 2041           goto(10,630,740,630,630,630,630,630,630,630,30,50,70,90,110,  &
 2042      &130,150,170,190,210,420,440,460,480,500,520,540,560,580,600,      &
 2043      &620,390,230,250,270,290,310,330,350,370,680,700,720,630,748,      &
 2044      &630,630,630,630,630,745,746),ktrack(i)
 2045           goto 630
 2046    10     stracki=strack(i)
 2047           do 20 j=1,napx
 2048             xv(1,j)=xv(1,j)+stracki*yv(1,j)
 2049             xv(2,j)=xv(2,j)+stracki*yv(2,j)
 2050    20     continue
 2051           goto 630
 2052 !--HORIZONTAL DIPOLE
 2053    30     do 40 j=1,napx
 2054             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
 2055             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
 2056    40     continue
 2057           goto 620
 2058 !--NORMAL QUADRUPOLE
 2059    50     do 60 j=1,napx
 2060             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2061      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2062             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2063      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2064             crkve=xlv(j)
 2065             cikve=zlv(j)
 2066             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2067      &stracks(i)*cikve)
 2068             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2069      &stracks(i)*crkve)
 2070    60     continue
 2071           goto 620
 2072 !--NORMAL SEXTUPOLE
 2073    70     do 80 j=1,napx
 2074             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2075      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2076             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2077      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2078             crkve=xlv(j)
 2079             cikve=zlv(j)
 2080            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2081            cikve=crkve*zlv(j)+cikve*xlv(j)
 2082            crkve=crkveuk
 2083             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2084      &stracks(i)*cikve)
 2085             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2086      &stracks(i)*crkve)
 2087    80     continue
 2088           goto 620
 2089 !--NORMAL OCTUPOLE
 2090    90     do 100 j=1,napx
 2091             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2092      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2093             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2094      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2095             crkve=xlv(j)
 2096             cikve=zlv(j)
 2097            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2098            cikve=crkve*zlv(j)+cikve*xlv(j)
 2099            crkve=crkveuk
 2100            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2101            cikve=crkve*zlv(j)+cikve*xlv(j)
 2102            crkve=crkveuk
 2103             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2104      &stracks(i)*cikve)
 2105             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2106      &stracks(i)*crkve)
 2107   100     continue
 2108           goto 620
 2109 !--NORMAL DECAPOLE
 2110   110     do 120 j=1,napx
 2111             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2112      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2113             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2114      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2115             crkve=xlv(j)
 2116             cikve=zlv(j)
 2117            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2118            cikve=crkve*zlv(j)+cikve*xlv(j)
 2119            crkve=crkveuk
 2120            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2121            cikve=crkve*zlv(j)+cikve*xlv(j)
 2122            crkve=crkveuk
 2123            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2124            cikve=crkve*zlv(j)+cikve*xlv(j)
 2125            crkve=crkveuk
 2126             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2127      &stracks(i)*cikve)
 2128             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2129      &stracks(i)*crkve)
 2130   120     continue
 2131           goto 620
 2132 !--NORMAL DODECAPOLE
 2133   130     do 140 j=1,napx
 2134             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2135      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2136             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2137      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2138             crkve=xlv(j)
 2139             cikve=zlv(j)
 2140            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2141            cikve=crkve*zlv(j)+cikve*xlv(j)
 2142            crkve=crkveuk
 2143            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2144            cikve=crkve*zlv(j)+cikve*xlv(j)
 2145            crkve=crkveuk
 2146            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2147            cikve=crkve*zlv(j)+cikve*xlv(j)
 2148            crkve=crkveuk
 2149            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2150            cikve=crkve*zlv(j)+cikve*xlv(j)
 2151            crkve=crkveuk
 2152             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2153      &stracks(i)*cikve)
 2154             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2155      &stracks(i)*crkve)
 2156   140     continue
 2157           goto 620
 2158 !--NORMAL 14-POLE
 2159   150     do 160 j=1,napx
 2160             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2161      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2162             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2163      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2164             crkve=xlv(j)
 2165             cikve=zlv(j)
 2166            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2167            cikve=crkve*zlv(j)+cikve*xlv(j)
 2168            crkve=crkveuk
 2169            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2170            cikve=crkve*zlv(j)+cikve*xlv(j)
 2171            crkve=crkveuk
 2172            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2173            cikve=crkve*zlv(j)+cikve*xlv(j)
 2174            crkve=crkveuk
 2175            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2176            cikve=crkve*zlv(j)+cikve*xlv(j)
 2177            crkve=crkveuk
 2178            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2179            cikve=crkve*zlv(j)+cikve*xlv(j)
 2180            crkve=crkveuk
 2181             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2182      &stracks(i)*cikve)
 2183             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2184      &stracks(i)*crkve)
 2185   160     continue
 2186           goto 620
 2187 !--NORMAL 16-POLE
 2188   170     do 180 j=1,napx
 2189             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2190      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2191             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2192      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2193             crkve=xlv(j)
 2194             cikve=zlv(j)
 2195            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2196            cikve=crkve*zlv(j)+cikve*xlv(j)
 2197            crkve=crkveuk
 2198            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2199            cikve=crkve*zlv(j)+cikve*xlv(j)
 2200            crkve=crkveuk
 2201            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2202            cikve=crkve*zlv(j)+cikve*xlv(j)
 2203            crkve=crkveuk
 2204            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2205            cikve=crkve*zlv(j)+cikve*xlv(j)
 2206            crkve=crkveuk
 2207            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2208            cikve=crkve*zlv(j)+cikve*xlv(j)
 2209            crkve=crkveuk
 2210            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2211            cikve=crkve*zlv(j)+cikve*xlv(j)
 2212            crkve=crkveuk
 2213             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2214      &stracks(i)*cikve)
 2215             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2216      &stracks(i)*crkve)
 2217   180     continue
 2218           goto 620
 2219 !--NORMAL 18-POLE
 2220   190     do 200 j=1,napx
 2221             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2222      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2223             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2224      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2225             crkve=xlv(j)
 2226             cikve=zlv(j)
 2227            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2228            cikve=crkve*zlv(j)+cikve*xlv(j)
 2229            crkve=crkveuk
 2230            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2231            cikve=crkve*zlv(j)+cikve*xlv(j)
 2232            crkve=crkveuk
 2233            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2234            cikve=crkve*zlv(j)+cikve*xlv(j)
 2235            crkve=crkveuk
 2236            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2237            cikve=crkve*zlv(j)+cikve*xlv(j)
 2238            crkve=crkveuk
 2239            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2240            cikve=crkve*zlv(j)+cikve*xlv(j)
 2241            crkve=crkveuk
 2242            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2243            cikve=crkve*zlv(j)+cikve*xlv(j)
 2244            crkve=crkveuk
 2245            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2246            cikve=crkve*zlv(j)+cikve*xlv(j)
 2247            crkve=crkveuk
 2248             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2249      &stracks(i)*cikve)
 2250             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2251      &stracks(i)*crkve)
 2252   200     continue
 2253           goto 620
 2254 !--NORMAL 20-POLE
 2255   210     do 220 j=1,napx
 2256             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2257      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2258             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2259      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2260             crkve=xlv(j)
 2261             cikve=zlv(j)
 2262            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2263            cikve=crkve*zlv(j)+cikve*xlv(j)
 2264            crkve=crkveuk
 2265            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2266            cikve=crkve*zlv(j)+cikve*xlv(j)
 2267            crkve=crkveuk
 2268            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2269            cikve=crkve*zlv(j)+cikve*xlv(j)
 2270            crkve=crkveuk
 2271            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2272            cikve=crkve*zlv(j)+cikve*xlv(j)
 2273            crkve=crkveuk
 2274            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2275            cikve=crkve*zlv(j)+cikve*xlv(j)
 2276            crkve=crkveuk
 2277            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2278            cikve=crkve*zlv(j)+cikve*xlv(j)
 2279            crkve=crkveuk
 2280            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2281            cikve=crkve*zlv(j)+cikve*xlv(j)
 2282            crkve=crkveuk
 2283            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2284            cikve=crkve*zlv(j)+cikve*xlv(j)
 2285            crkve=crkveuk
 2286             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2287      &stracks(i)*cikve)
 2288             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 2289      &stracks(i)*crkve)
 2290   220     continue
 2291           goto 620
 2292   230     continue
 2293           do 240 j=1,napx
 2294             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 2295      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2296             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 2297      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2298             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 2299      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 2300      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 2301             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 2302      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 2303      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 2304   240     continue
 2305           goto 620
 2306   250     continue
 2307           do 260 j=1,napx
 2308             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 2309      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2310             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 2311      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2312             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 2313      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 2314      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 2315             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 2316      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 2317      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 2318   260     continue
 2319           goto 390
 2320   270     continue
 2321           do 280 j=1,napx
 2322             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 2323      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 2324             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 2325      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 2326   280     continue
 2327           goto 620
 2328   290     continue
 2329           do 300 j=1,napx
 2330             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 2331      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 2332             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 2333      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 2334   300     continue
 2335           goto 390
 2336   310     continue
 2337           do 320 j=1,napx
 2338             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 2339      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2340             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 2341      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2342             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 2343      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 2344      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 2345             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 2346      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 2347      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 2348   320     continue
 2349           goto 620
 2350   330     continue
 2351           do 340 j=1,napx
 2352             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 2353      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2354             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 2355      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2356             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 2357      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 2358      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 2359             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 2360      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 2361      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 2362   340     continue
 2363           goto 390
 2364   350     continue
 2365           do 360 j=1,napx
 2366             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 2367      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 2368             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 2369      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 2370   360     continue
 2371           goto 620
 2372   370     continue
 2373           do 380 j=1,napx
 2374             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 2375      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 2376             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 2377      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 2378   380     continue
 2379   390     r0=ek(ix)
 2380           nmz=nmu(ix)
 2381           if(nmz.ge.2) then
 2382             do 410 j=1,napx
 2383             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 2384      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2385             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 2386      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2387               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
 2388               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
 2389               crkve=xlvj
 2390               cikve=zlvj
 2391                 do 400 k=3,nmz
 2392                   crkveuk=crkve*xlvj-cikve*zlvj
 2393                   cikve=crkve*zlvj+cikve*xlvj
 2394                   crkve=crkveuk
 2395                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
 2396                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
 2397   400           continue
 2398               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
 2399               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
 2400   410       continue
 2401           else
 2402             do 415 j=1,napx
 2403               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
 2404      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
 2405               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
 2406      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
 2407   415       continue
 2408           endif
 2409           goto 620
 2410 !--SKEW ELEMENTS
 2411 !--VERTICAL DIPOLE
 2412   420     do 430 j=1,napx
 2413             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
 2414             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
 2415   430     continue
 2416           goto 620
 2417 !--SKEW QUADRUPOLE
 2418   440     do 450 j=1,napx
 2419             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2420      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2421             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2422      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2423             crkve=xlv(j)
 2424             cikve=zlv(j)
 2425             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2426      &stracks(i)*crkve)
 2427             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2428      &stracks(i)*cikve)
 2429   450     continue
 2430           goto 620
 2431 !--SKEW SEXTUPOLE
 2432   460     do 470 j=1,napx
 2433             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2434      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2435             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2436      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2437             crkve=xlv(j)
 2438             cikve=zlv(j)
 2439            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2440            cikve=crkve*zlv(j)+cikve*xlv(j)
 2441            crkve=crkveuk
 2442             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2443      &stracks(i)*crkve)
 2444             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2445      &stracks(i)*cikve)
 2446   470     continue
 2447           goto 620
 2448 !--SKEW OCTUPOLE
 2449   480     do 490 j=1,napx
 2450             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2451      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2452             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2453      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2454             crkve=xlv(j)
 2455             cikve=zlv(j)
 2456            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2457            cikve=crkve*zlv(j)+cikve*xlv(j)
 2458            crkve=crkveuk
 2459            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2460            cikve=crkve*zlv(j)+cikve*xlv(j)
 2461            crkve=crkveuk
 2462             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2463      &stracks(i)*crkve)
 2464             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2465      &stracks(i)*cikve)
 2466   490     continue
 2467           goto 620
 2468 !--SKEW DECAPOLE
 2469   500     do 510 j=1,napx
 2470             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2471      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2472             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2473      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2474             crkve=xlv(j)
 2475             cikve=zlv(j)
 2476            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2477            cikve=crkve*zlv(j)+cikve*xlv(j)
 2478            crkve=crkveuk
 2479            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2480            cikve=crkve*zlv(j)+cikve*xlv(j)
 2481            crkve=crkveuk
 2482            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2483            cikve=crkve*zlv(j)+cikve*xlv(j)
 2484            crkve=crkveuk
 2485             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2486      &stracks(i)*crkve)
 2487             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2488      &stracks(i)*cikve)
 2489   510     continue
 2490           goto 620
 2491 !--SKEW DODECAPOLE
 2492   520     do 530 j=1,napx
 2493             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2494      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2495             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2496      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2497             crkve=xlv(j)
 2498             cikve=zlv(j)
 2499            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2500            cikve=crkve*zlv(j)+cikve*xlv(j)
 2501            crkve=crkveuk
 2502            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2503            cikve=crkve*zlv(j)+cikve*xlv(j)
 2504            crkve=crkveuk
 2505            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2506            cikve=crkve*zlv(j)+cikve*xlv(j)
 2507            crkve=crkveuk
 2508            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2509            cikve=crkve*zlv(j)+cikve*xlv(j)
 2510            crkve=crkveuk
 2511             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2512      &stracks(i)*crkve)
 2513             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2514      &stracks(i)*cikve)
 2515   530     continue
 2516           goto 620
 2517 !--SKEW 14-POLE
 2518   540     do 550 j=1,napx
 2519             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2520      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2521             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2522      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2523             crkve=xlv(j)
 2524             cikve=zlv(j)
 2525            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2526            cikve=crkve*zlv(j)+cikve*xlv(j)
 2527            crkve=crkveuk
 2528            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2529            cikve=crkve*zlv(j)+cikve*xlv(j)
 2530            crkve=crkveuk
 2531            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2532            cikve=crkve*zlv(j)+cikve*xlv(j)
 2533            crkve=crkveuk
 2534            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2535            cikve=crkve*zlv(j)+cikve*xlv(j)
 2536            crkve=crkveuk
 2537            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2538            cikve=crkve*zlv(j)+cikve*xlv(j)
 2539            crkve=crkveuk
 2540             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2541      &stracks(i)*crkve)
 2542             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2543      &stracks(i)*cikve)
 2544   550     continue
 2545           goto 620
 2546 !--SKEW 16-POLE
 2547   560     do 570 j=1,napx
 2548             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2549      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2550             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2551      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2552             crkve=xlv(j)
 2553             cikve=zlv(j)
 2554            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2555            cikve=crkve*zlv(j)+cikve*xlv(j)
 2556            crkve=crkveuk
 2557            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2558            cikve=crkve*zlv(j)+cikve*xlv(j)
 2559            crkve=crkveuk
 2560            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2561            cikve=crkve*zlv(j)+cikve*xlv(j)
 2562            crkve=crkveuk
 2563            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2564            cikve=crkve*zlv(j)+cikve*xlv(j)
 2565            crkve=crkveuk
 2566            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2567            cikve=crkve*zlv(j)+cikve*xlv(j)
 2568            crkve=crkveuk
 2569            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2570            cikve=crkve*zlv(j)+cikve*xlv(j)
 2571            crkve=crkveuk
 2572             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2573      &stracks(i)*crkve)
 2574             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2575      &stracks(i)*cikve)
 2576   570     continue
 2577           goto 620
 2578 !--SKEW 18-POLE
 2579   580     do 590 j=1,napx
 2580             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2581      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2582             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2583      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2584             crkve=xlv(j)
 2585             cikve=zlv(j)
 2586            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2587            cikve=crkve*zlv(j)+cikve*xlv(j)
 2588            crkve=crkveuk
 2589            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2590            cikve=crkve*zlv(j)+cikve*xlv(j)
 2591            crkve=crkveuk
 2592            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2593            cikve=crkve*zlv(j)+cikve*xlv(j)
 2594            crkve=crkveuk
 2595            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2596            cikve=crkve*zlv(j)+cikve*xlv(j)
 2597            crkve=crkveuk
 2598            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2599            cikve=crkve*zlv(j)+cikve*xlv(j)
 2600            crkve=crkveuk
 2601            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2602            cikve=crkve*zlv(j)+cikve*xlv(j)
 2603            crkve=crkveuk
 2604            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2605            cikve=crkve*zlv(j)+cikve*xlv(j)
 2606            crkve=crkveuk
 2607             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2608      &stracks(i)*crkve)
 2609             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2610      &stracks(i)*cikve)
 2611   590     continue
 2612           goto 620
 2613 !--SKEW 20-POLE
 2614   600     do 610 j=1,napx
 2615             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 2616      &(xv(2,j)-zsiv(1,i))*tilts(i)
 2617             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 2618      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 2619             crkve=xlv(j)
 2620             cikve=zlv(j)
 2621            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2622            cikve=crkve*zlv(j)+cikve*xlv(j)
 2623            crkve=crkveuk
 2624            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2625            cikve=crkve*zlv(j)+cikve*xlv(j)
 2626            crkve=crkveuk
 2627            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2628            cikve=crkve*zlv(j)+cikve*xlv(j)
 2629            crkve=crkveuk
 2630            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2631            cikve=crkve*zlv(j)+cikve*xlv(j)
 2632            crkve=crkveuk
 2633            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2634            cikve=crkve*zlv(j)+cikve*xlv(j)
 2635            crkve=crkveuk
 2636            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2637            cikve=crkve*zlv(j)+cikve*xlv(j)
 2638            crkve=crkveuk
 2639            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2640            cikve=crkve*zlv(j)+cikve*xlv(j)
 2641            crkve=crkveuk
 2642            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 2643            cikve=crkve*zlv(j)+cikve*xlv(j)
 2644            crkve=crkveuk
 2645             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 2646      &stracks(i)*crkve)
 2647             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 2648      &stracks(i)*cikve)
 2649   610     continue
 2650           goto 620
 2651   680     continue
 2652           do 690 j=1,napx
 2653               if(ibbc.eq.0) then
 2654                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 2655                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 2656               else
 2657                 crkveb(j)=                                              &
 2658      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 2659      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 2660                 cikveb(j)=                                              &
 2661      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 2662      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 2663               endif
 2664             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
 2665             if(rho2b(j).le.pieni)                                       &
 2666      &goto 690
 2667             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
 2668             if(ibbc.eq.0) then
 2669               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
 2670      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
 2671               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
 2672      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
 2673             else
 2674               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 2675      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
 2676      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 2677      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 2678               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 2679               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 2680      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
 2681      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 2682      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 2683               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 2684             endif
 2685   690     continue
 2686           goto 620
 2687   700     continue
 2688           if(ibtyp.eq.0) then
 2689             do j=1,napx
 2690               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 2691               rb(j)=sqrt(r2b(j))
 2692               rkb(j)=strack(i)*pisqrt/rb(j)
 2693               if(ibbc.eq.0) then
 2694                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 2695                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 2696               else
 2697                 crkveb(j)=                                              &
 2698      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 2699      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 2700                 cikveb(j)=                                              &
 2701      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 2702      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 2703               endif
 2704               xrb(j)=abs(crkveb(j))/rb(j)
 2705               zrb(j)=abs(cikveb(j))/rb(j)
 2706               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
 2707               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 2708      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 2709               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 2710               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 2711               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
 2712               if(ibbc.eq.0) then
 2713                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 2714      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 2715                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 2716      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 2717               else
 2718                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2719      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2720      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2721      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 2722                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 2723                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2724      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2725      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2726      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 2727                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 2728               endif
 2729             enddo
 2730           else if(ibtyp.eq.1) then
 2731             do j=1,napx
 2732               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 2733               rb(j)=sqrt(r2b(j))
 2734               rkb(j)=strack(i)*pisqrt/rb(j)
 2735               if(ibbc.eq.0) then
 2736                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 2737                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 2738               else
 2739                 crkveb(j)=                                              &
 2740      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 2741      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 2742                 cikveb(j)=                                              &
 2743      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 2744      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 2745               endif
 2746               xrb(j)=abs(crkveb(j))/rb(j)
 2747               zrb(j)=abs(cikveb(j))/rb(j)
 2748               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 2749      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 2750               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 2751               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 2752             enddo
 2753             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
 2754             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
 2755             do j=1,napx
 2756               if(ibbc.eq.0) then
 2757                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 2758      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 2759                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 2760      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 2761               else
 2762                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2763      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2764      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2765      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 2766                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 2767                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2768      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2769      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2770      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 2771                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 2772               endif
 2773             enddo
 2774           endif
 2775           goto 620
 2776   720     continue
 2777           if(ibtyp.eq.0) then
 2778             do j=1,napx
 2779               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 2780               rb(j)=sqrt(r2b(j))
 2781               rkb(j)=strack(i)*pisqrt/rb(j)
 2782               if(ibbc.eq.0) then
 2783                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 2784                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 2785               else
 2786                 crkveb(j)=                                              &
 2787      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 2788      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 2789                 cikveb(j)=                                              &
 2790      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 2791      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 2792               endif
 2793               xrb(j)=abs(crkveb(j))/rb(j)
 2794               zrb(j)=abs(cikveb(j))/rb(j)
 2795               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
 2796               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 2797      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 2798               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 2799               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 2800               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
 2801               if(ibbc.eq.0) then
 2802                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 2803      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 2804                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 2805      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 2806               else
 2807                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2808      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2809      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2810      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 2811                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 2812                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2813      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2814      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2815      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 2816                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 2817               endif
 2818             enddo
 2819           else if(ibtyp.eq.1) then
 2820             do j=1,napx
 2821               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 2822               rb(j)=sqrt(r2b(j))
 2823               rkb(j)=strack(i)*pisqrt/rb(j)
 2824               if(ibbc.eq.0) then
 2825                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 2826                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 2827               else
 2828                 crkveb(j)=                                              &
 2829      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 2830      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 2831                 cikveb(j)=                                              &
 2832      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 2833      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 2834               endif
 2835               xrb(j)=abs(crkveb(j))/rb(j)
 2836               zrb(j)=abs(cikveb(j))/rb(j)
 2837               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 2838      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 2839               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 2840               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 2841             enddo
 2842             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
 2843             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
 2844             do j=1,napx
 2845               if(ibbc.eq.0) then
 2846                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 2847      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 2848                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 2849      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 2850               else
 2851                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2852      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2853      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2854      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 2855                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 2856                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 2857      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 2858      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 2859      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 2860                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 2861               endif
 2862             enddo
 2863           endif
 2864           goto 620
 2865   740     continue
 2866           irrtr=imtr(ix)
 2867           do j=1,napx
 2868             pux=xv(1,j)
 2869             dpsv3(j)=dpsv(j)*c1e3
 2870             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
 2871      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
 2872             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
 2873      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
 2874             pux=xv(2,j)
 2875             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
 2876      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
 2877             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
 2878      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
 2879           enddo
 2880  
 2881 !----------------------------------------------------------------------
 2882  
 2883 ! Wire.
 2884  
 2885           goto 620
 2886   745     continue
 2887           xory=1
 2888           nfree=nturn1(ix)
 2889          if(n.gt.nfree) then
 2890           nac=n-nfree
 2891           pi=4d0*atan(1d0)
 2892 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 2893 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 2894           acdipamp=ed(ix)*clight*1.0d-3
 2895 !---------Qd input in tune units
 2896           qd=ek(ix)
 2897 !---------ACphase input in radians
 2898           acphase=acdipph(ix)
 2899           nramp1=nturn2(ix)
 2900           nplato=nturn3(ix)
 2901           nramp2=nturn4(ix)
 2902           do j=1,napx
 2903       if (xory.eq.1) then
 2904         acdipamp2=acdipamp*tilts(i)
 2905         acdipamp1=acdipamp*tiltc(i)
 2906       else
 2907         acdipamp2=acdipamp*tiltc(i)
 2908         acdipamp1=-acdipamp*tilts(i)
 2909       endif
 2910               if(nramp1.gt.nac) then
 2911                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 2912      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 2913                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 2914      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 2915               endif
 2916               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 2917                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 2918      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 2919                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 2920      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 2921               endif
 2922               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 2923      &nac)then
 2924               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 2925      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 2926               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 2927      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 2928               endif
 2929       enddo
 2930       endif
 2931           goto 620
 2932   746     continue
 2933           xory=2
 2934           nfree=nturn1(ix)
 2935          if(n.gt.nfree) then
 2936           nac=n-nfree
 2937           pi=4d0*atan(1d0)
 2938 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 2939 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 2940           acdipamp=ed(ix)*clight*1.0d-3
 2941 !---------Qd input in tune units
 2942           qd=ek(ix)
 2943 !---------ACphase input in radians
 2944           acphase=acdipph(ix)
 2945           nramp1=nturn2(ix)
 2946           nplato=nturn3(ix)
 2947           nramp2=nturn4(ix)
 2948           do j=1,napx
 2949       if (xory.eq.1) then
 2950         acdipamp2=acdipamp*tilts(i)
 2951         acdipamp1=acdipamp*tiltc(i)
 2952       else
 2953         acdipamp2=acdipamp*tiltc(i)
 2954         acdipamp1=-acdipamp*tilts(i)
 2955       endif
 2956               if(nramp1.gt.nac) then
 2957                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 2958      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 2959                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 2960      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 2961               endif
 2962               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 2963                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 2964      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 2965                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 2966      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 2967               endif
 2968               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 2969      &nac)then
 2970               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 2971      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 2972               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 2973      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 2974               endif
 2975       enddo
 2976       endif
 2977           goto 620
 2978  
 2979 !----------------------------
 2980  
 2981 ! Wire.
 2982  
 2983   748     continue
 2984 !     magnetic rigidity
 2985       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
 2986  
 2987       ix = ixcav
 2988       tx = xrms(ix)
 2989       ty = zrms(ix)
 2990       dx = xpl(ix)
 2991       dy = zpl(ix)
 2992       embl = ek(ix)
 2993       l = wirel(ix)
 2994       cur = ed(ix)
 2995  
 2996       leff = embl/cos(tx)/cos(ty)
 2997       rx = dx *cos(tx)-embl*sin(tx)/2
 2998       lin= dx *sin(tx)+embl*cos(tx)/2
 2999       ry = dy *cos(ty)-lin *sin(ty)
 3000       lin= lin*cos(ty)+dy  *sin(ty)
 3001  
 3002       do 750 j=1, napx
 3003  
 3004       xv(1,j) = xv(1,j) * c1m3
 3005       xv(2,j) = xv(2,j) * c1m3
 3006       yv(1,j) = yv(1,j) * c1m3
 3007       yv(2,j) = yv(2,j) * c1m3
 3008  
 3009 !      print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
 3010 !     &yv(2,j)
 3011  
 3012 !     call drift(-embl/2)
 3013  
 3014       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 3015      &yv(2,j)**2)
 3016       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 3017      &yv(2,j)**2)
 3018  
 3019 !     call tilt(tx,ty)
 3020  
 3021       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
 3022      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 3023      &yv(2,j)**2))-tx)
 3024       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
 3025      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
 3026       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 3027      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
 3028  
 3029       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
 3030      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 3031      &yv(2,j)**2))-ty)
 3032       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
 3033      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
 3034       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 3035      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
 3036  
 3037 !     call drift(lin)
 3038  
 3039       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 3040      &yv(2,j)**2)
 3041       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 3042      &yv(2,j)**2)
 3043  
 3044 !      call kick(l,cur,lin,rx,ry,chi)
 3045  
 3046       xi = xv(1,j)-rx
 3047       yi = xv(2,j)-ry
 3048       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
 3049      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 3050      &xi**2+yi**2))
 3051 !GRD FOR CONSISTENSY
 3052 !      yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)*                  &
 3053       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
 3054      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 3055      &xi**2+yi**2))
 3056  
 3057 !     call drift(leff-lin)
 3058  
 3059       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
 3060      &yv(1,j)**2-yv(2,j)**2)
 3061       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
 3062      &yv(1,j)**2-yv(2,j)**2)
 3063  
 3064 !     call invtilt(tx,ty)
 3065  
 3066       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
 3067      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 3068      &yv(2,j)**2))+ty)
 3069       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
 3070      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
 3071       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 3072      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
 3073  
 3074       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
 3075      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 3076      &yv(2,j)**2))+tx)
 3077       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
 3078      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
 3079       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 3080      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
 3081  
 3082 !     call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
 3083  
 3084       xv(1,j) = xv(1,j) + embl*tan(tx)
 3085       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
 3086  
 3087 !     call drift(-embl/2)
 3088  
 3089       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 3090      &yv(2,j)**2)
 3091       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 3092      &yv(2,j)**2)
 3093  
 3094       xv(1,j) = xv(1,j) * c1e3
 3095       xv(2,j) = xv(2,j) * c1e3
 3096       yv(1,j) = yv(1,j) * c1e3
 3097       yv(2,j) = yv(2,j) * c1e3
 3098  
 3099 !      print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
 3100 !     &yv(2,j)
 3101  
 3102 !-----------------------------------------------------------------------
 3103  
 3104   750     continue
 3105           goto 620
 3106  
 3107 !----------------------------
 3108  
 3109   620     continue
 3110           llost=.false.
 3111           do j=1,napx
 3112              llost=llost.or.                                            &
 3113      &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
 3114           enddo
 3115           if (llost) then
 3116              kpz=abs(kp(ix))
 3117              if(kpz.eq.2) then
 3118                 call lostpar3(i,ix,nthinerr)
 3119                 if(nthinerr.ne.0) return
 3120              elseif(kpz.eq.3) then
 3121                 call lostpar4(i,ix,nthinerr)
 3122                 if(nthinerr.ne.0) return
 3123              else
 3124                 call lostpar2(i,ix,nthinerr)
 3125                 if(nthinerr.ne.0) return
 3126              endif
 3127           endif
 3128   630   continue
 3129         call lostpart(nthinerr)
 3130         if(nthinerr.ne.0) return
 3131         if(ntwin.ne.2) call dist1
 3132         if(mod(n,nwr(4)).eq.0) call write6(n)
 3133   640 continue
 3134       return
 3135       end
 3136       subroutine thin6d(nthinerr)
 3137 !-----------------------------------------------------------------------
 3138 !
 3139 !  TRACK THIN LENS 6D
 3140 !
 3141 !
 3142 !  F. SCHMIDT
 3143 !-----------------------------------------------------------------------
 3144       implicit none
 3145       integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
 3146       double precision c5m4,cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,   &
 3147      &crkveuk,crxb,crzb,dpsv3,pux,r0,r2b,rb,rho2b,rkb,stracki,tkb,xbb,  &
 3148      &xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
 3149       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 3150      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 3151      &nrco,ntr,nzfz
 3152       parameter(npart = 64,nmac = 1)
 3153       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 3154      &nzfz = 300000,mmul = 11)
 3155       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 3156      &nema = 15)
 3157       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 3158       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 3159       parameter(nmon1 = 600,ncor1 = 600)
 3160       parameter(ntr = 20,nbb = 160)
 3161       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
 3162       double precision e0fo,e0o,xv1j,xv2j
 3163       double precision acdipamp, qd, acphase,acdipamp2,acdipamp1
 3164       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
 3165       logical llost
 3166       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 3167      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 3168      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 3169      &one,pieni,pmae,pmap,three,two,zero
 3170       parameter(pieni = 1d-38)
 3171       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 3172       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 3173       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 3174       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 3175       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 3176      &1.0d16)
 3177       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 3178       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 3179       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 3180       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 3181       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 3182       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 3183       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 3184       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 3185       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 3186      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 3187      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 3188      &imc,imtr,iorg,iout,                                               &
 3189      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 3190      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 3191      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 3192      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 3193      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 3194      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 3195      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 3196      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 3197      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 3198       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 3199      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 3200      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 3201      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 3202      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 3203      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 3204      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 3205      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 3206      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 3207      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 3208      &acdipph
 3209       real hmal
 3210       character*16 bez,bezb,bezr,erbez,bezl
 3211       character*80 toptit,sixtit,commen
 3212       common/erro/ierro,erbez
 3213       common/kons/pi,pi2,pisqrt,rad
 3214       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 3215       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 3216       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 3217       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 3218       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 3219       common/syos2/rvf(mpa)
 3220       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 3221      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 3222       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 3223      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 3224      &iicav,itionc(nele),ition,idp,ncy,ixcav
 3225       common/corcom/dpscor,sigcor,icode,idam,its6d
 3226       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 3227      &bka(nele,mmul),aka(nele,mmul)
 3228       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 3229       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 3230       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 3231      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 3232       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 3233       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 3234      &iout
 3235       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 3236       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 3237      &ntco,eui,euii,nlin,bezl(nele)
 3238       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 3239      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 3240      &ncororb(nele)
 3241       common/apert/apx(nele),apz(nele),ape(3,nele)
 3242       common/clos/sigma0(2),iclo,ncorru,ncorrep
 3243       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 3244      &ratioe(nele),iratioe(nele),icoe
 3245       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 3246       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 3247       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 3248       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 3249       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 3250      &nstart,nstop,iskip,iconv,imad
 3251       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 3252       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 3253       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 3254       common/ripp2/nrturn
 3255       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 3256       common/pawc/hmal(nplo)
 3257       common/tit/sixtit,commen,ithick
 3258       common/co6d/clo6(3),clop6(3)
 3259       common/dkic/dki(nele,3)
 3260       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 3261      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 3262      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 3263      &nbeam,ibbc,ibeco,ibtyp,lhc
 3264       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 3265       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 3266       common/wireco/ wirel(nele)
 3267       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 3268      &nturn3(nele), nturn4(nele)
 3269       integer idz,itra
 3270       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 3271       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 3272      &dps(mpa),idz(2)
 3273       common/anf/chi0,chid,exz(2,6),dp1,itra
 3274       integer ichrom,is
 3275       double precision alf0,amp,bet0,clo,clop,cro,x,y
 3276       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 3277       common/chrom/cro(2),is(2),ichrom
 3278       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 3279      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 3280       double precision dpmax,preda,weig1,weig2
 3281       character*16 coel
 3282       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 3283       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 3284       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 3285      &coel(10)
 3286       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 3287      &zsi
 3288       real tlim,time0,time1
 3289       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 3290      &aai(nblz,mmul),bbi(nblz,mmul)
 3291       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 3292       common/damp/damp,ampt
 3293       common/ttime/tlim,time0,time1
 3294       double precision tasm
 3295       common/tasm/tasm(6,6)
 3296       integer iv,ixv,nlostp,nms,numxv
 3297       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 3298      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 3299      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 3300      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 3301      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 3302      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 3303      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 3304      &zsiv,zsv
 3305       logical pstop
 3306       common/main1/                                                     &
 3307      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 3308      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 3309      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 3310      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 3311      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 3312      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 3313      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 3314      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 3315       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 3316      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 3317      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 3318      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 3319      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 3320      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 3321      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 3322      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 3323      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 3324       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 3325      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 3326      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 3327      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 3328       integer numx
 3329       double precision e0f
 3330       common/main4/ e0f,numx
 3331       integer ktrack,nwri
 3332       double precision dpsv1,strack,strackc,stracks
 3333       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 3334      &stracks(nblz),dpsv1(npart),nwri
 3335       double precision cc,xlim,ylim
 3336       parameter(cc = 1.12837916709551d0)
 3337       parameter(xlim = 5.33d0)
 3338       parameter(ylim = 4.29d0)
 3339       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
 3340      &r2b(npart),rb(npart),rkb(npart),                                  &
 3341      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
 3342      &crzb(npart),cbxb(npart),cbzb(npart)
 3343       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
 3344 !UPGRADE January 2005
 3345 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
 3346       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
 3347      &maxn=20000,outlun=54)
 3348 !
 3349 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
 3350 !
 3351       integer ieff
 3352 !
 3353       double precision myemitx0,myemity0,myalphay,mybetay,myalphax,     &
 3354      &mybetax,rselect
 3355       common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax,       &
 3356      &mybetay,rselect
 3357 !
 3358       integer absorbed(npart),counted(npart,numeff)
 3359       double precision neff(numeff),rsig(numeff)
 3360       common  /eff/ neff,rsig,counted,absorbed
 3361 !
 3362       integer  nimpact(50)
 3363       double precision sumimpact(50),sqsumimpact(50)
 3364       common  /rimpact/ sumimpact,sqsumimpact,nimpact
 3365 !
 3366       integer  nampl(nblz)
 3367       character*16  ename(nblz)
 3368       double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz),        &
 3369      &sqsum_ay(nblz),sampl(nblz)
 3370       common  /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename,   &
 3371      &nampl
 3372 !
 3373       double precision neffx(numeff),neffy(numeff)
 3374       common /efficiency/ neffx,neffy
 3375 !
 3376       integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed   &
 3377      &,part_select(maxn)
 3378       double precision part_impact(maxn)
 3379       common /stats/ part_impact,part_hit,part_abs
 3380       common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
 3381       common /part_select/ part_select
 3382 !
 3383       double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
 3384       common   /beam00/ x00,xp00,y00,yp00
 3385 !
 3386       logical firstrun
 3387       common /firstrun/ firstrun
 3388 !
 3389       integer nsurvive,nsurvive_end,num_selhit,n_impact
 3390       common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
 3391 !
 3392       integer napx00
 3393       common /napx00/ napx00
 3394 !
 3395       integer  icoll
 3396       common  /icoll/  icoll
 3397 !
 3398 !UPGRADE January 2005
 3399 !     INTEGER DB_NCOLL
 3400       integer db_ncoll
 3401 !
 3402 ! For re-initializtion of random generator
 3403       integer   mclock_liar
 3404 !
 3405       character*16 db_name1(max_ncoll),db_name2(max_ncoll)
 3406       character*6 db_material(max_ncoll)
 3407       double precision db_nsig(max_ncoll),db_length(max_ncoll),         &
 3408      &db_offset(max_ncoll),db_rotation(max_ncoll),                      &
 3409      &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2),           &
 3410      &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll)
 3411      &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll),                  &
 3412      &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll),                  &
 3413      &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
 3414      &,db_miscut(max_ncoll)
 3415       common /colldatabase/ db_nsig,db_length,db_rotation,db_offset,    &
 3416      &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll,       &
 3417      &db_elense_thickness,db_elense_j_e
 3418      &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
 3419      &db_cry_tilt,db_miscut
 3420 !
 3421       integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
 3422       double precision caverage(max_ncoll),csigma(max_ncoll)
 3423       common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
 3424 !
 3425       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
 3426      &myp(maxn),mys(maxn)
 3427       common /coord/ myx,myxp,myy,myyp,myp,mys
 3428 !
 3429       integer counted_r(maxn,numeff),counted_x(maxn,numeff),            &
 3430      &counted_y(maxn,numeff),                                           &
 3431      &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
 3432       common /counting/ counted_r,counted_x,counted_y,ieffmax_r,        &
 3433      &ieffmax_x, ieffmax_y
 3434 !
 3435       integer secondary(maxn),tertiary(maxn),other(maxn),               &
 3436      &part_hit_before(maxn)
 3437       double precision part_indiv(maxn),part_linteract(maxn)
 3438 !
 3439       integer   samplenumber
 3440       character*4 smpl
 3441       character*80 pfile
 3442       common /samplenumber/ pfile,smpl,samplenumber
 3443 !
 3444 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3445 !
 3446 !
 3447 !
 3448       logical cut_input,firstcoll,found,onesided
 3449 !
 3450       integer myktrack,n_gt72,n_gt80,n_gt90,nx_gt72,nx_gt80,            &
 3451      &ny_gt72,ny_gt80,rnd_lux,rnd_k1,rnd_k2,ios,num_surhit,numbin,ibin, &
 3452      &num_selabs,iturn_last_hit,iturn_absorbed,iturn_survive,imov,      &
 3453      &ipart(npart),totalelem,selelem,unitnumber,distnumber,turnnumber,  &
 3454      &jb,myix,                                                          &
 3455      &flukaname(npart)
 3456       integer jjj, ijk
 3457 !
 3458       double precision  ran_gauss, myran_gauss
 3459       real rndm5,zbv
 3460 !
 3461       double precision c_length    !length in m
 3462       double precision c_rotation  !rotation angle vs vertical in radian
 3463       double precision c_aperture  !aperture in m
 3464       double precision c_offset    !offset in m
 3465       double precision c_tilt(2)   !tilt in radian
 3466       double precision cx(npart),cxp(npart),cy(npart),cyp(npart),       &
 3467      &cp(npart),cs(npart),rcx(npart),rcxp(npart),rcy(npart),rcyp(npart),&
 3468      &rcp(npart),rcs(npart),rcx0(npart),rcxp0(npart),rcy0(npart),       &
 3469      &rcyp0(npart),rcp0(npart),enom_gev,totals,betax,betay,xmax,ymax,   &
 3470      &nsig,calc_aperture,gammax,gammay,gammax0,gammay0,gammax1,gammay1, &
 3471      &xj,xpj,yj,ypj,pj,arcdx,arcbetax,xdisp,nspx,nspy,rxjco,ryjco,      &
 3472      &rxpjco,rypjco,dummy,mux(nblz),muy(nblz),mux0,muy0,c_rmstilt,      &
 3473      &c_systilt,scale_bx,scale_by,scale_bx0,scale_by0,xkick,            &
 3474      &ykick,bx_dist,by_dist,xmax_pencil,ymax_pencil,xmax_nom,ymax_nom,  &
 3475      &nom_aperture,pencil_aperture,xp_pencil(max_ncoll),                &
 3476      &yp_pencil(max_ncoll),x_pencil0,y_pencil0,sum,sqsum,               &
 3477      &csum(max_ncoll),csqsum(max_ncoll),average,sigma,sigsecut,nspxd,   &
 3478      &xndisp,xgrd(npart),xpgrd(npart),ygrd(npart),ypgrd(npart),         &
 3479      &pgrd(npart),ejfvgrd(npart),sigmvgrd(npart),rvvgrd(npart),         &
 3480      &dpsvgrd(npart),oidpsvgrd(npart),dpsv1grd(npart),                  &
 3481      &ax0,ay0,bx0,by0,dnormx,dnormy,driftx,drifty,                      &
 3482      &xnorm,xpnorm,xangle,ynorm,ypnorm,yangle,xbob(nblz),ybob(nblz),    &
 3483      &xpbob(nblz),ypbob(nblz),xineff(npart),yineff(npart),              &
 3484      &xpineff(npart),ypineff(npart),grdpiover2,grdpiover4,grd3piover4
 3485       double precision x_sl(100),x1_sl(100),x2_sl(100),                 &
 3486      &     y1_sl(100), y2_sl(100),                                      &
 3487      &     angle1(100), angle2(100),                                    &
 3488      &     max_tmp,                                                     &
 3489      &     a_tmp1, a_tmp2
 3490 !
 3491       character*6 c_material     !material
 3492 !
 3493       common /cut/ cut_input
 3494       common /mu/ mux, muy
 3495       common /xcheck/ xbob,ybob,xpbob,ypbob,xineff,yineff,xpineff,      &
 3496      &ypineff
 3497 !
 3498 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3499 !
 3500 !GRD
 3501 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
 3502 !GRD
 3503 !APRIL2005
 3504       logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside,     &
 3505      &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial,        &
 3506      &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
 3507       integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber,         &
 3508      &do_thisdis,n_slices,pencil_distr
 3509       double precision myenom,mynex,mdex,myney,mdey,                    &
 3510      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
 3511      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
 3512 !
 3513      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
 3514      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
 3515 !
 3516      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
 3517 !SEPT2005 add these lines for the slicing procedure
 3518      &smin_slices,smax_slices,recenter1,recenter2,                      &
 3519      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
 3520      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
 3521 !SEPT2005,OCT2006 added offset
 3522      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
 3523      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
 3524      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
 3525      &c_sysoffset_sec,c_rmserror_gap,nr,ndr,                            &
 3526      &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,            &
 3527      &sigsecut3,sigsecut2,enerror,bunchlength
 3528 !
 3529       character*16 name_coll
 3530       character*24 name_sel
 3531       character*80 coll_db
 3532       character*16 castordir
 3533       character*80 filename_dis
 3534 !
 3535       common /grd/ myenom,mynex,mdex,myney,mdey,                        &
 3536      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
 3537      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
 3538 !
 3539      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
 3540      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
 3541 !
 3542      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
 3543 !
 3544      &smin_slices,smax_slices,recenter1,recenter2,                      &
 3545      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
 3546      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
 3547 !
 3548      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
 3549      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
 3550      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
 3551      &c_sysoffset_sec,c_rmserror_gap,nr,                                &
 3552 !
 3553      &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,        &
 3554      &sigsecut3,sigsecut2,enerror,                                      &
 3555      &bunchlength,coll_db,name_sel,                                     &
 3556      &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed,          &
 3557      &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr,                 &
 3558      &do_coll,                                                          &
 3559 !
 3560      &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
 3561      &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
 3562      &dowritetracks,cern,do_nsig,do_mingap
 3563 !
 3564 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3565 !
 3566 !
 3567 ! THIS BLOCK IS COMMON TO WRITELIN,LINOPT,TRAUTHIN,THIN6D AND MAINCR
 3568 !
 3569       double precision tbetax(nblz),tbetay(nblz),talphax(nblz),         &
 3570      &talphay(nblz),torbx(nblz),torbxp(nblz),torby(nblz),torbyp(nblz),  &
 3571      &tdispx(nblz),tdispy(nblz)
 3572 !
 3573       common /rtwiss/ tbetax,tbetay,talphax,talphay,torbx,torbxp,       &
 3574      &torby,torbyp,tdispx,tdispy
 3575 !
 3576 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3577 !
 3578 ! Variables for finding the collimator with the smallest gap
 3579 ! and defining, stroring the gap rms error
 3580 !
 3581       character*16 coll_mingap1, coll_mingap2
 3582       double precision gap_rms_error(max_ncoll), nsig_err, sig_offset
 3583       double precision mingap,gap_h1,gap_h2,gap_h3,gap_h4
 3584       integer coll_mingap_id
 3585 !
 3586 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3587 !
 3588 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
 3589 !
 3590       integer ipencil
 3591       double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll),       &
 3592      &y_pencil(max_ncoll),pencil_dx(max_ncoll)
 3593       common  /pencil/  xp_pencil0,yp_pencil0,pencil_dx,ipencil
 3594       common  /pencil2/ x_pencil, y_pencil
 3595 !
 3596 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3597 !
 3598       integer ie,iturn,nabs_total
 3599       common  /info/ ie,iturn,nabs_total
 3600 !--September 2006 -- TW common to readcollimator and collimate2
 3601 !      logical           changed_tilt1(max_ncoll)
 3602 !      logical           changed_tilt2(max_ncoll)
 3603 !      common /tilt/ changed_tilt1, changed_tilt2
 3604 !--September 2006
 3605 !
 3606 !
 3607 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
 3608 ! SEPT2008 JCSMITH
 3609 ! electron lense parameters
 3610        integer this_elense ! which elense we are currently looking at
 3611        integer, parameter :: n_elense = 10 
 3612        double precision elense_r_min(n_elense)
 3613        double precision elense_r_max(n_elense)
 3614        double precision elense_j_e(n_elense)
 3615        double precision elense_length(n_elense)
 3616     
 3617        common /elense/ elense_r_min, elense_r_max, elense_j_e,          &
 3618      &                elense_length
 3619 ! SEPT2008
 3620       integer nprim
 3621 !
 3622       dimension dpsv3(npart)
 3623 !-----------------------------------------------------------------------
 3624 !SEPT 2008 valentina
 3625 ! crystal parameters
 3626 ! Cry_length crystal length [m]
 3627 ! Rcurv curvature radius [m]
 3628 ! C_xmax thickness of the crystal [m]
 3629 ! C_ymax height of the crystal [m]
 3630 ! Alayer thickness of amorphous layer [m]
 3631 ! C_orient crystalline planes orientation
 3632 ! Cry_tilt0 beam natural divergence at the crystal position
 3633 ! Cry_tilt total tilt of the crystal (orientation + c_tilt0)
 3634 !      
 3635 ! bool_proc(j) is set, for each particle, after the last passage from a
 3636 ! crystal. bool_proc(j)=1: amorphous ,  bool_proc(j)=2: volume reflection,
 3637 ! bool_proc(j)=3: channeling, bool_proc(j)=4: dechanneling
 3638 !  bool_proc(j)=5: absorbed ,bool_proc(j)=6: volume capture
 3639 !
 3640 ! bool_create is just to check that the distribution of particles has
 3641 ! alredy been created
 3642 !
 3643 ! write_c_out, write_SPS_out are flags to activate more output files for
 3644 ! the crystal
 3645 !
 3646       double precision  Cry_length, Rcurv,C_xmax,C_ymax,Alayer,C_orient
 3647       double precision  Cry_Bending
 3648       double precision miscut  !miscut angle in rad
 3649       common/miscut/ miscut
 3650       common /Par_Cry1/ Cry_length, Rcurv,C_xmax,C_ymax,Alayer,C_orient
 3651       double precision Cry_tilt,Cry_tilt0
 3652       common /Par_Cry2/ Cry_tilt,Cry_tilt0
 3653       integer  bool_proc(maxn)
 3654       integer  bool_proc_old(maxn)
 3655       logical bool_create
 3656       logical write_c_out, write_SPS_out
 3657       common /Process/ bool_proc,bool_create
 3658       common /Process_old/ bool_proc_old
 3659       common /outputs/ write_c_out, write_SPS_out
 3660 !
 3661       double precision  X_NORM,XP_NORM,Y_NORM,YP_NORM
 3662 !
 3663
 3664       double precision xdebug(nblz),xdebugN(nblz),xpdebug(nblz),
 3665      & xpdebugN(nblz),
 3666      & ydebug(nblz),ydebugN(nblz),ypdebug(nblz),ypdebugN(nblz)
 3667       common /debugvale/xdebug,xdebugN,xpdebug,xpdebugN,
 3668      &ydebug,ydebugN,ypdebug,ypdebugN
 3669
 3670 !
 3671       double precision totals_vale
 3672       
 3673 !---------------------------------------------------------------------------
 3674       save
 3675       
 3676       c5m4=5.0d-4
 3677       nthinerr=0
 3678 !++  Some initialization
 3679 !
 3680       do i = 1, numeff
 3681         rsig(i) = dble(i)/2d0 - 0.5d0 + 6d0
 3682       enddo
 3683       n_gt72 = 0
 3684       n_gt80 = 0
 3685       n_gt90 = 0
 3686       nx_gt72 = 0
 3687       nx_gt80 = 0
 3688       ny_gt72 = 0
 3689       ny_gt80 = 0
 3690       firstcoll = .true.
 3691       napx = napx00
 3692       do j = 1, napx
 3693          part_hit(j)    = 0
 3694          part_abs(j)    = 0
 3695          part_impact(j) = 0
 3696       enddo
 3697 !    
 3698 !++   This we only do once, for the first call to this routine. Numbers
 3699 !++   are saved in memory to use exactly the same info for each sample.
 3700 !++   COMMON block to decide for first usage and to save coll info.
 3701 !    
 3702 !--------------------------------------------------------------------
 3703 !++   Read collimator database
 3704       if (firstrun) then
 3705 !    
 3706          call readcollimator
 3707 !    
 3708          write(*,*) 'number of collimators', db_ncoll
 3709          do icoll = 1, db_ncoll
 3710             write(*,*) 'COLLIMATOR', icoll, ' ', db_name1(icoll)
 3711             write(*,*) 'collimator', icoll, ' ', db_name2(icoll)
 3712          end do
 3713 !******write settings for alignment error in colltrack.out file
 3714 !
 3715       write(outlun,*) ' '
 3716       write(outlun,*) 'Alignment errors settings (tilt, offset,...)'
 3717       write(outlun,*) ' '
 3718       write(outlun,*) 'SETTING> c_rmstilt_prim   : ', c_rmstilt_prim
 3719       write(outlun,*) 'SETTING> c_rmstilt_sec    : ', c_rmstilt_sec
 3720       write(outlun,*) 'SETTING> c_systilt_prim   : ', c_systilt_prim
 3721       write(outlun,*) 'SETTING> c_systilt_sec    : ', c_systilt_sec
 3722       write(outlun,*) 'SETTING> c_rmsoffset_prim : ', c_rmsoffset_prim
 3723       write(outlun,*) 'SETTING> c_rmsoffset_sec  : ', c_rmsoffset_sec
 3724       write(outlun,*) 'SETTING> c_sysoffset_prim : ', c_sysoffset_prim
 3725       write(outlun,*) 'SETTING> c_sysoffset_sec  : ', c_sysoffset_sec
 3726       write(outlun,*) 'SETTING> c_offsettilt seed: ', c_offsettilt_seed
 3727       write(outlun,*) 'SETTING> c_rmserror_gap   : ', c_rmserror_gap
 3728       write(outlun,*) 'SETTING> do_mingap        : ', do_mingap
 3729       write(outlun,*) ' '
 3730 !     added offset and random_seed for tilt and offset
 3731 !*****intialize random generator with offset_seed
 3732       c_offsettilt_seed = abs(c_offsettilt_seed)
 3733       rnd_lux = 3
 3734       rnd_k1  = 0
 3735       rnd_k2  = 0
 3736       call rluxgo(rnd_lux, c_offsettilt_seed, rnd_k1, rnd_k2)        
 3737 !      write(outlun,*) 'INFO>  c_offsettilt seed: ', c_offsettilt_seed
 3738 !
 3739 ! reset counter to assure starting at the same position in case of
 3740 ! using rndm5 somewhere else in the code before
 3741 !
 3742       zbv = rndm5(1)
 3743 !
 3744 !++  Generate random tilts (Gaussian distribution plus systematic)
 3745 !++  Do this only for the first call of this routine (first sample)
 3746 !++  Keep all collimator database info and errors in memeory (COMMON
 3747 !++  block) in order to re-use exactly the same information for every
 3748 !++  sample.
 3749 !
 3750          if (c_rmstilt_prim.gt.0. .or. c_rmstilt_sec.gt.0. .or.         &
 3751      &        c_systilt_prim.ne.0. .or. c_systilt_sec.ne.0.) then
 3752             do icoll = 1, db_ncoll
 3753                if (db_name1(icoll)(1:3).eq.'TCP') then
 3754                   c_rmstilt = c_rmstilt_prim
 3755                   c_systilt = c_systilt_prim
 3756                else
 3757                   c_rmstilt = c_rmstilt_sec
 3758                   c_systilt = c_systilt_sec
 3759                endif
 3760                db_tilt(icoll,1) = c_systilt+c_rmstilt*myran_gauss(3d0)
 3761                if (systilt_antisymm) then
 3762                   db_tilt(icoll,2) =                                    &
 3763      &                 -1d0*c_systilt+c_rmstilt*myran_gauss(3d0)
 3764                else
 3765                   db_tilt(icoll,2) =                                    &
 3766      &                 c_systilt+c_rmstilt*myran_gauss(3d0)
 3767                endif
 3768                write(outlun,*) 'INFO>  Collimator ', db_name1(icoll),   &
 3769      &              ' jaw 1 has tilt [rad]: ', db_tilt(icoll,1)
 3770                write(outlun,*) 'INFO>  Collimator ', db_name1(icoll),   &
 3771      &              ' jaw 2 has tilt [rad]: ', db_tilt(icoll,2)
 3772             end do
 3773          endif
 3774 !++  Generate random offsets (Gaussian distribution plus systematic)
 3775 !++  Do this only for the first call of this routine (first sample)
 3776 !++  Keep all collimator database info and errors in memeory (COMMON
 3777 !++  block) in order to re-use exactly the same information for every
 3778 !++  sample and throughout a all run.
 3779          if (c_sysoffset_prim.ne.0. .or. c_sysoffset_sec.ne.0. .or.     &
 3780      &        c_rmsoffset_prim.gt.0. .or. c_rmsoffset_sec.gt.0.) then
 3781             do icoll = 1, db_ncoll
 3782                if (db_name1(icoll)(1:3).eq.'TCP') then
 3783                   db_offset(icoll) = c_sysoffset_prim +                 &
 3784      &                 c_rmsoffset_prim*myran_gauss(3d0)
 3785                else
 3786                   db_offset(icoll) = c_sysoffset_sec +                  &
 3787      &                 c_rmsoffset_sec*myran_gauss(3d0)
 3788                endif
 3789                write(outlun,*) 'INFO>  offset: ', db_name1(icoll),      &
 3790      &              db_offset(icoll)
 3791             end do
 3792          endif
 3793 !++  Generate random offsets (Gaussian distribution)
 3794 !++  Do this only for the first call of this routine (first sample)
 3795 !++  Keep all collimator database info and errors in memeory (COMMON
 3796 !++  block) in order to re-use exactly the same information for every
 3797 !++  sample and throughout a all run.
 3798             do icoll = 1, db_ncoll
 3799                gap_rms_error(icoll) = c_rmserror_gap * myran_gauss(3d0)
 3800                write(outlun,*) 'INFO>  gap_rms_error: ',                &
 3801      &              db_name1(icoll),gap_rms_error(icoll)
 3802             end do
 3803 !
 3804 !---- creating a file with beta-functions at TCP/TCS
 3805          open(unit=10000, file='twisslike.out')
 3806          open(unit=10001, file='sigmasettings.out')
 3807          mingap = 20
 3808          do j=1,iu
 3809 ! this transformation gives the right marker/name to the corresponding
 3810 ! beta-dunctions or vice versa ;)
 3811             if(ic(j).le.nblo) then
 3812                do jb=1,mel(ic(j))
 3813                   myix=mtyp(ic(j),jb)
 3814                enddo
 3815             else
 3816                myix=ic(j)-nblo
 3817             endif
 3818 ! Using same code-block as below to evalute the collimator opening
 3819 ! for each collimator, this is needed to get the smallest collimator gap
 3820 ! in principal only looking for primary and secondary should be enough
 3821 ! JULY 2008 added changes (V6.503) for names in TCTV -> TCTVA amd TCTVB
 3822 ! both namings before and after V6.503 can be used
 3823             if ( bez(myix)(1:2).eq.'TC'                                 &
 3824      &           .or. bez(myix)(1:2).eq.'tc'                            &
 3825      &           .or. bez(myix)(1:2).eq.'TD'                            &
 3826      &           .or. bez(myix)(1:2).eq.'td'                            &
 3827      &           .or. bez(myix)(1:3).eq.'COL'                           &
 3828      &           .or. bez(myix)(1:3).eq.'col'
 3829      &           .or. bez(myix)(1:3).eq.'CRY'       !valentina add crystal
 3830      &           .or. bez(myix)(1:3).eq.'cry') then
 3831                if(bez(myix)(1:3).eq.'TCP' .or.                          &
 3832      &              bez(myix)(1:3).eq.'tcp') then
 3833                   if(bez(myix)(7:9).eq.'3.B' .or.                       &
 3834      &                 bez(myix)(7:9).eq.'3.b') then
 3835                      nsig = nsig_tcp3
 3836                   else
 3837                      nsig = nsig_tcp7
 3838                   endif
 3839                elseif(bez(myix)(1:4).eq.'TCSG' .or.                     &
 3840      &                 bez(myix)(1:4).eq.'tcsg' .or.
 3841      &                 bez(myix)(1:4).eq.'TCSP' .or.
 3842      &                 bez(myix)(1:4).eq.'tcsp'  ) then
 3843                   if(bez(myix)(8:10).eq.'3.B' .or.                      &
 3844      &                 bez(myix)(8:10).eq.'3.b' .or.                    &
 3845      &                 bez(myix)(9:11).eq.'3.B' .or.                    &
 3846      &                 bez(myix)(9:11).eq.'3.b') then
 3847                      nsig = nsig_tcsg3
 3848                   else
 3849                      nsig = nsig_tcsg7
 3850                   endif
 3851                   if((bez(myix)(5:6).eq.'.4'.and.bez(myix)(8:9).eq.'6.')&
 3852      &                 ) then
 3853                      nsig = nsig_tcstcdq
 3854                   endif
 3855                elseif(bez(myix)(1:4).eq.'TCSM' .or.                     &
 3856      &                 bez(myix)(1:4).eq.'tcsm') then
 3857                   if(bez(myix)(8:10).eq.'3.B' .or.                      &
 3858      &                 bez(myix)(8:10).eq.'3.b' .or.                    &
 3859      &                 bez(myix)(9:11).eq.'3.B' .or.                    &
 3860      &                 bez(myix)(9:11).eq.'3.b') then
 3861                      nsig = nsig_tcsm3
 3862                   else
 3863                      nsig = nsig_tcsm7
 3864                   endif
 3865                elseif(bez(myix)(1:4).eq.'TCLA' .or.                     &
 3866      &                 bez(myix)(1:4).eq.'tcla') then
 3867                   if(bez(myix)(9:11).eq.'7.B' .or.                      &
 3868      &                 bez(myix)(9:11).eq.'7.b') then
 3869                      nsig = nsig_tcla7
 3870                   else
 3871                      nsig = nsig_tcla3
 3872                   endif
 3873                elseif(bez(myix)(1:4).eq.'TCDQ' .or.                     &
 3874      &                 bez(myix)(1:4).eq.'tcdq') then
 3875                   nsig = nsig_tcdq
 3876                elseif(bez(myix)(1:4).eq.'TCTH' .or.                     &
 3877      &                 bez(myix)(1:4).eq.'tcth' ) then                  &
 3878                   if(bez(myix)(8:10).eq.'1.B' .or.                      &
 3879      &                 bez(myix)(8:10).eq.'1.b') then
 3880                      nsig = nsig_tcth1
 3881                   elseif(bez(myix)(8:10).eq.'2.B' .or.                  &
 3882      &                    bez(myix)(8:10).eq.'2.b') then
 3883                      nsig = nsig_tcth2
 3884                   elseif(bez(myix)(8:10).eq.'5.B' .or.                  &
 3885      &                    bez(myix)(8:10).eq.'5.b') then
 3886                      nsig = nsig_tcth5
 3887                   elseif(bez(myix)(8:10).eq.'8.B' .or.                  &
 3888      &                    bez(myix)(8:10).eq.'8.b') then
 3889                      nsig = nsig_tcth8
 3890                   endif
 3891                elseif(bez(myix)(1:4).eq.'TCTV' .or.                     &
 3892      &                 bez(myix)(1:4).eq.'tctv' ) then
 3893                   if(bez(myix)(8:10).eq.'1.B' .or.                      &
 3894      &                 bez(myix)(8:10).eq.'1.b' .or.                    &
 3895      &                 bez(myix)(9:11).eq.'1.B' .or.                    &
 3896      &                 bez(myix)(9:11).eq.'1.b' ) then
 3897                      nsig = nsig_tctv1
 3898                   elseif(bez(myix)(8:10).eq.'2.B' .or.                  &
 3899      &                    bez(myix)(8:10).eq.'2.b' .or.                 &
 3900      &                    bez(myix)(9:11).eq.'2.B' .or.                 &
 3901      &                    bez(myix)(9:11).eq.'2.b' ) then
 3902                      nsig = nsig_tctv2
 3903                   elseif(bez(myix)(8:10).eq.'5.B' .or.                  &
 3904      &                    bez(myix)(8:10).eq.'5.b' .or.                 &
 3905      &                    bez(myix)(9:11).eq.'5.B' .or.                 &
 3906      &                    bez(myix)(9:11).eq.'5.b') then
 3907                      nsig = nsig_tctv5
 3908                   elseif(bez(myix)(8:10).eq.'8.B' .or.                  &
 3909      &                    bez(myix)(8:10).eq.'8.b' .or.                 &
 3910      &                    bez(myix)(9:11).eq.'8.B' .or.                 &
 3911      &                    bez(myix)(9:11).eq.'8.b') then
 3912                      nsig = nsig_tctv8
 3913                   endif
 3914                elseif(bez(myix)(1:3).eq.'TDI' .or.                      &
 3915      &                 bez(myix)(1:3).eq.'tdi') then
 3916                   nsig = nsig_tdi
 3917                elseif(bez(myix)(1:4).eq.'TCLP' .or.                     &
 3918      &                 bez(myix)(1:4).eq.'tclp' .or.                    &
 3919      &                 bez(myix)(1:4).eq.'TCL.' .or.                    &
 3920      &                 bez(myix)(1:4).eq.'tcl.') then
 3921                   nsig = nsig_tclp
 3922                elseif(bez(myix)(1:4).eq.'TCLI' .or.                     &
 3923      &                 bez(myix)(1:4).eq.'tcli') then
 3924                   nsig = nsig_tcli
 3925                elseif(bez(myix)(1:4).eq.'TCXR' .or.                     &
 3926      &                 bez(myix)(1:4).eq.'tcxr') then
 3927                   nsig = nsig_tcxrp
 3928 !     TW 04/2008 ---- start adding TCRYO
 3929                elseif(bez(myix)(1:5).eq.'TCRYO' .or.                     &
 3930      &                 bez(myix)(1:5).eq.'tcryo') then
 3931                   nsig = nsig_tcryo
 3932 !     TW 04/2008 ---- end adding TCRYO
 3933 !     valentina SEPT2008 ---- start adding CRY
 3934                elseif(bez(myix)(1:3).eq.'CRY' .or.                    
 3935      &                 bez(myix)(1:3).eq.'cry') then
 3936                   nsig = nsig_cry
 3937 !     valentina SEPT2008 ---- end adding CRY
 3938                elseif(bez(myix)(1:3).eq.'COL' .or.                      &
 3939      &                 bez(myix)(1:3).eq.'col') then
 3940                   if(bez(myix)(1:4).eq.'COLM' .or.                      &
 3941      &                 bez(myix)(1:4).eq.'colm' .or.                    &
 3942      &                 bez(myix)(1:5).eq.'COLH0' .or.                   &
 3943      &                 bez(myix)(1:5).eq.'colh0') then
 3944                      nsig = nsig_tcth1
 3945                   elseif(bez(myix)(1:5).eq.'COLV0' .or.                 &
 3946      &                    bez(myix)(1:5).eq.'colv0') then
 3947                      nsig = nsig_tcth2
 3948                   elseif(bez(myix)(1:5).eq.'COLH1' .or.                 &
 3949      &                    bez(myix)(1:5).eq.'colh1') then
 3950 !     JUNE2005   HERE WE USE NSIG_TCTH2 AS THE OPENING IN THE VERTICAL
 3951 !     JUNE2005   PLANE FOR THE PRIMARY COLLIMATOR OF RHIC; NSIG_TCTH5 STANDS
 3952 !     JUNE2005   FOR THE OPENING OF THE FIRST SECONDARY COLLIMATOR OF RHIC
 3953                      nsig = nsig_tcth5
 3954                   elseif(bez(myix)(1:5).eq.'COLV1' .or.                 &
 3955      &                    bez(myix)(1:5).eq.'colv1') then
 3956                      nsig = nsig_tcth8
 3957                   elseif(bez(myix)(1:5).eq.'COLH2' .or.                 &
 3958      &                    bez(myix)(1:5).eq.'colh2') then
 3959                      nsig = nsig_tctv1
 3960                   endif
 3961 !     JUNE2005   END OF DEDICATED TREATMENT OF RHIC OPENINGS
 3962                endif
 3963 !     FEBRUAR2007
 3964                do i = 1, db_ncoll
 3965 !
 3966 ! start searching minimum gap
 3967 !
 3968                   if ((db_name1(i)(1:11).eq.bez(myix)(1:11)) .or.       &
 3969      &                 (db_name2(i)(1:11).eq.bez(myix)(1:11))) then
 3970                      if ( db_length(i) .gt. 0d0 ) then
 3971                         nsig_err = nsig + gap_rms_error(i)
 3972 ! jaw 1 on positive side x-axis
 3973                         gap_h1 = nsig_err - sin(db_tilt(i,1))*          &
 3974      &                       db_length(i)/2
 3975                         gap_h2 = nsig_err + sin(db_tilt(i,1))*          &
 3976      &                       db_length(i)/2
 3977 ! jaw 2 on negative side of x-axis (see change of sign comapred
 3978 ! to above code lines, alos have a look to setting of tilt angle)
 3979                         gap_h3 = nsig_err + sin(db_tilt(i,2))*          &
 3980      &                       db_length(i)/2
 3981                         gap_h4 = nsig_err - sin(db_tilt(i,2))*          &
 3982      &                       db_length(i)/2
 3983 ! find minumum halfgap
 3984 ! --- searching for smallest halfgap
 3985                         if (do_nominal) then                            
 3986                            bx_dist = db_bx(icoll)
 3987                            by_dist = db_by(icoll)
 3988                         else
 3989                            bx_dist = tbetax(j)
 3990                            by_dist = tbetay(j)
 3991                         endif
 3992                         sig_offset = db_offset(i) /                     &
 3993      &                       (sqrt(bx_dist**2 * cos(db_rotation(i))**2  &
 3994      &                       + by_dist**2 * sin(db_rotation(i))**2 ))
 3995                         write(10000,*) bez(myix),tbetax(j),tbetay(j),   &
 3996      &                       torbx(j),torby(j), nsig, gap_rms_error(i)
 3997                         write(10001,*) bez(myix), gap_h1, gap_h2,       &
 3998      &                       gap_h3, gap_h4, sig_offset, db_offset(i),  &
 3999      &                       nsig, gap_rms_error(i)
 4000                         if ((gap_h1 + sig_offset) .le. mingap) then
 4001                            mingap = gap_h1 + sig_offset
 4002                            coll_mingap_id = i
 4003                            coll_mingap1 = db_name1(i)
 4004                            coll_mingap2 = db_name2(i)
 4005                         elseif ((gap_h2 + sig_offset) .le. mingap) then
 4006                            mingap = gap_h2 + sig_offset
 4007                            coll_mingap_id = i
 4008                            coll_mingap1 = db_name1(i)
 4009                            coll_mingap2 = db_name2(i)
 4010                         elseif ((gap_h3 - sig_offset) .le. mingap) then
 4011                            mingap = gap_h3 - sig_offset
 4012                            coll_mingap_id = i
 4013                            coll_mingap1 = db_name1(i)
 4014                            coll_mingap2 = db_name2(i)
 4015                         elseif ((gap_h4 - sig_offset) .le. mingap) then
 4016                            mingap = gap_h4 - sig_offset
 4017                            coll_mingap_id = i
 4018                            coll_mingap1 = db_name1(i)
 4019                            coll_mingap2 = db_name2(i)
 4020                         endif
 4021                      endif
 4022                   endif
 4023                enddo
 4024 !    
 4025 ! could be done more elegant the above code to search the minimum gap
 4026 ! and should also consider the jaw tilt
 4027 !
 4028             endif
 4029          enddo
 4030          write(10000,*) 'minimum gap collimator:',coll_mingap_id,
 4031      &    coll_mingap1,coll_mingap2, mingap
 4032          write(10000,*) 'INFO> IPENCIL initial ',ipencil
 4033 ! if pencil beam is used and on collimator with smallest gap the
 4034 ! distribution should be generated, set ipencil to coll_mingap_id    
 4035          if (ipencil.gt.0 .and. do_mingap) then
 4036             ipencil = coll_mingap_id
 4037          endif
 4038          write(10000,*) 'INFO> IPENCIL new (if do_mingap) ',ipencil
 4039 ! ---
 4040          write(10001,*) coll_mingap_id,coll_mingap1,coll_mingap2,       &
 4041      &        mingap
 4042 ! if pencil beam is used and on collimator with smallest gap the
 4043 ! distribution should be generated, set ipencil to coll_mingap_id    
 4044          write(10001,*) 'INFO> IPENCIL new (if do_mingap) ',ipencil
 4045          write(10001,*) 'INFO> rnd_seed is (before reinit)',rnd_seed
 4046 !
 4047          close(10000)
 4048          close(10001)
 4049 !
 4050 !****** re-intialize random generator with rnd_seed
 4051 !       reinit with initial value used in first call  
 4052          rnd_lux = 3
 4053          rnd_k1  = 0
 4054          rnd_k2  = 0
 4055          call rluxgo(rnd_lux, rnd_seed, rnd_k1, rnd_k2)
 4056 !
 4057 !GRD
 4058 !GRD INITIALIZE LOCAL ADDITIVE PARAMETERS, ie THE ONE WE DON'T WANT
 4059 !GRD TO KEEP OVER EACH LOOP
 4060 !GRD
 4061          do j=1,napx
 4062             tertiary(j)=0
 4063             secondary(j)=0
 4064             other(j)=0
 4065          end do
 4066 !GRD
 4067           do k = 1, numeff
 4068             neff(k)  = 0d0
 4069             neffx(k) = 0d0
 4070             neffy(k) = 0d0
 4071           enddo
 4072 !
 4073 !Mars 2005
 4074           do j=1,max_ncoll
 4075             cn_impact(j) = 0
 4076             cn_absorbed(j) = 0
 4077             csum(j) = 0d0
 4078             csqsum(j) = 0d0
 4079           enddo
 4080 !Mars 2005
 4081 !++ End of first call stuff (end of first run)
 4082 !
 4083       endif
 4084 !
 4085 !++ Moved initialization to the start of EACH set, RA/GRD 14/6/04
 4086 !
 4087       do j=1,napx
 4088         tertiary(j)=0
 4089         secondary(j)=0
 4090 !APRIL2005
 4091         other(j)=0
 4092 !APRIL2005
 4093       end do
 4094 !GRD
 4095 !GRD HERE WE INITIALIZE THE VALUES OF IPART(j)
 4096 !GRD
 4097       do j=1,napx
 4098          ipart(j) = j
 4099          flukaname(j) = 0
 4100       end do
 4101 !GRD
 4102 !GRD NOW WE CAN BEGIN THE LOOPS
 4103 !GRD
 4104       open(unit=99,file='betatron.dat')
 4105       do 660 n=1,numl
 4106        iturn=n
 4107        numx=n-1
 4108         if(irip.eq.1) call ripple(n)
 4109         if(mod(numx,nwri).eq.0) call writebin(nthinerr)
 4110         if(nthinerr.ne.0) return
 4111         totals=0d0
 4112         totals_vale=0d0
 4113       do 650 i=1,iu
 4114       ie=i
 4115 !
 4116 !++  For absorbed particles set all coordinates to zero. Also
 4117 !++  include very large offsets, let's say above 100mm or
 4118 !++  100mrad.
 4119 !
 4120           do j = 1, napx
 4121             if (part_abs(j).gt.0 .or.                                   &
 4122      &xv(1,j).gt.100d0 .or.                                             &
 4123      &yv(1,j).gt.100d0 .or.                                             &
 4124      &xv(2,j).gt.100d0 .or.                                             &
 4125      &yv(2,j).gt.100d0) then
 4126               xv(1,j) = 0d0
 4127               yv(1,j) = 0d0
 4128               xv(2,j) = 0d0
 4129               yv(2,j) = 0d0
 4130               ejv(j)  = myenom
 4131               sigmv(j)= 0d0
 4132               part_abs(j) = 10000*ie + iturn
 4133               secondary(j) = 0
 4134               tertiary(j)  = 0
 4135               other(j) = 0
 4136             endif
 4137           end do
 4138 !GRD
 4139 !GRD SAVE COORDINATES OF PARTICLE 1 TO CHECK ORBIT
 4140 !GRD
 4141          if(firstrun) then
 4142         xbob(ie)=xv(1,1)
 4143        !xbob [mm] is the transverse coordinate of the first particle
 4144        !of the first bunch at the first turn
 4145         ybob(ie)=xv(2,1)
 4146         xpbob(ie)=yv(1,1)
 4147         ypbob(ie)=yv(2,1)
 4148         endif
 4149 !++  Here comes sixtrack stuff
 4150 !
 4151         if(ic(i).le.nblo) then
 4152               do jb=1,mel(ic(i))
 4153                  myix=mtyp(ic(i),jb)
 4154               enddo
 4155            else
 4156               myix=ic(i)-nblo
 4157            endif
 4158           ix=ic(i)-nblo
 4159 !++  Make sure we go into collimation routine for any definition
 4160 !++  of collimator element, relying on element name instead.
 4161 !
 4162           if (                                                          &
 4163 !GRD HERE ARE SOME CHANGES TO MAKE RHIC TRAKING AVAILABLE
 4164      &   (bez(myix)(1:3).eq.'TCP'.or.bez(myix)(1:3).eq.'tcp') .or.      &
 4165      &   (bez(myix)(1:3).eq.'TCS'.or.bez(myix)(1:3).eq.'tcs') .or.      &
 4166      &   (bez(myix)(1:3).eq.'TCL'.or.bez(myix)(1:3).eq.'tcl') .or.      &
 4167      &   (bez(myix)(1:3).eq.'TCT'.or.bez(myix)(1:3).eq.'tct') .or.      &
 4168      &   (bez(myix)(1:3).eq.'TCD'.or.bez(myix)(1:3).eq.'tcd') .or.      &
 4169      &   (bez(myix)(1:3).eq.'TDI'.or.bez(myix)(1:3).eq.'tdi') .or.      &
 4170      &   (bez(myix)(1:3).eq.'TCX'.or.bez(myix)(1:3).eq.'tcx') .or.      &
 4171      &   (bez(myix)(1:3).eq.'TCR'.or.bez(myix)(1:3).eq.'tcr') .or.      &
 4172      &   (bez(myix)(1:3).eq.'COL'.or.bez(myix)(1:3).eq.'col') .or.      &
 4173      &   (bez(myix)(1:5).eq.'ELENS'.or.bez(myix)(1:5).eq.'elens') .or.  &
 4174      &   (bez(myix)(1:3).eq.'CRY'.or.bez(myix)(1:3).eq.'cry') ) then
 4175             myktrack = 1
 4176          else
 4177             myktrack = ktrack(i)
 4178          endif
 4179 c         if (n .eq.1 .and. i.eq.1 )
 4180 c     &    write(9999,*)"1=elem 2=npart 3=s 4=betax 5=alphax 6=x 7=y ",
 4181 c     &    "8=xp 9=yp 10=xnorm 11=ynorm 12=xpnorm 13=ypnorm 14=amplx",
 4182 c     &    "15=dispx 16=energy 17=orbx 18=orbx"
 4183          if (myktrack.eq.1) then 
 4184           totals_vale=totals_vale+strack(i)
 4185           if (strack(i).lt.0) write(*,*)"WARN:lenght <0!!!!,el=",ie
 4186      &    ,bez(myix),myktrack
 4187 c        
 4188 c          do j = 1, napx
 4189 c          write(9999,*)  i,j,
 4190 c     &    totals_vale,tbetax(ie),talphax(ie)  
 4191 c     &    ,xv(1,j),xv(2,j),yv(1,j),yv(2,j),
 4192 c     &    xv(1,j)/sqrt(myemitx0*tbetax(ie))/1d3,
 4193 c     &    xv(2,j)/sqrt(myemity0*tbetay(ie))/1d3,
 4194 c     &    (xv(1,j)/1d3*talphax(ie)+yv(1,j)/1d3*tbetax(ie))
 4195 c     &    /sqrt(myemitx0*tbetax(ie)),
 4196 c     &    (xv(2,j)/1d3*talphay(ie)+yv(2,j)/1d3*tbetay(ie))
 4197 c     &    /sqrt(myemity0*tbetay(ie)),
 4198 c     &     sqrt((xv(1,j)/sqrt(myemitx0*tbetax(ie))/1d3)**2 +
 4199 c     &    ((xv(1,j)/1d3*talphax(ie)+yv(1,j)/1d3*tbetax(ie))
 4200 c     &    /sqrt(myemitx0*tbetax(ie)))**2),tdispx(ie),ejv(j)
 4201 c     &    ,torbx(ie),torby(ie)    
 4202 c          enddo
 4203           endif
 4204           goto(10,30,740,650,650,650,650,650,650,650,50,70,90,110,130,  &
 4205      &150,170,190,210,230,440,460,480,500,520,540,560,580,600,620,      &
 4206      &640,410,250,270,290,310,330,350,370,390,680,700,720,730,748,      &
 4207      &650,650,650,650,650,745,746),myktrack
 4208           goto 650
 4209    10     stracki=strack(i)
 4210 !==========================================
 4211 !Ralph drift length is stracki
 4212 !bez(ix) is name of drift
 4213           totals=totals+stracki
 4214 !________________________________________________________________________
 4215 !++  If we have a collimator then...
 4216 !
 4217 !Feb2006
 4218 !GRD (June 2005) 'COL' option is for RHIC collimators
 4219 !
 4220 !     SR (17-01-2006): Special assignment to the TCS.TCDQ for B1 and B4,
 4221 !     using the new naming as in V6.500.
 4222 !     Note that this must be in the loop "if TCSG"!!
 4223 !
 4224 !     SR, 17-01-2006: Review the TCT assignments because the MADX names
 4225 !     have changes (TCTH.L -> TCTH.4L)
 4226 !
 4227 ! JULY 2008 added changes (V6.503) for names in TCTV -> TCTVA amd TCTVB
 4228 ! both namings before and after V6.503 can be used
 4229 !
 4230 !SEPT2008 JCSMITH
 4231 ! Added electorn lense collimator
 4232 !
 4233 !SEPT2008 valentina
 4234 ! Added crystal collimator
 4235           if (do_coll .and.
 4236      &    (bez(myix)(1:2).eq.'TC'                                  
 4237      &    .or. bez(myix)(1:2).eq.'tc'                              
 4238      &    .or. bez(myix)(1:2).eq.'TD'                              
 4239      &    .or. bez(myix)(1:2).eq.'td'                              
 4240      &    .or. bez(myix)(1:5).eq.'ELENS'                          
 4241      &    .or. bez(myix)(1:5).eq.'elens'                          
 4242      &    .or. bez(myix)(1:3).eq.'CRY'                            
 4243      &    .or. bez(myix)(1:3).eq.'cry'                            
 4244      &    .or. bez(myix)(1:3).eq.'COL'                            
 4245      &    .or. bez(myix)(1:3).eq.'col')) then
 4246                 if(bez(myix)(1:3).eq.'TCP' .or.                         &
 4247      &          bez(myix)(1:3).eq.'tcp') then
 4248                         if(bez(myix)(7:9).eq.'3.B' .or.                 &
 4249      &                  bez(myix)(7:9).eq.'3.b') then
 4250                                 nsig = nsig_tcp3
 4251                         else
 4252                                 nsig = nsig_tcp7
 4253                         endif
 4254                 elseif(bez(myix)(1:4).eq.'TCSG' .or.                    &
 4255      &                  bez(myix)(1:4).eq.'tcsg' .or.
 4256      &                  bez(myix)(1:4).eq.'TCSP' .or.
 4257      &                  bez(myix)(1:4).eq.'tcsp'  ) then
 4258                         if(bez(myix)(8:10).eq.'3.B' .or.                &
 4259      &                  bez(myix)(8:10).eq.'3.b' .or.                   &
 4260      &                  bez(myix)(9:11).eq.'3.B' .or.                   &
 4261      &                  bez(myix)(9:11).eq.'3.b') then
 4262                                 nsig = nsig_tcsg3
 4263                         else
 4264                                 nsig = nsig_tcsg7
 4265                         endif
 4266                         if((bez(myix)(5:6).eq.'.4'.and.
 4267      &                  bez(myix)(8:9).eq.'6.')    
 4268      &                  ) then
 4269                                 nsig = nsig_tcstcdq
 4270                         endif
 4271                 elseif(bez(myix)(1:4).eq.'TCSM' .or.                    &
 4272      &          bez(myix)(1:4).eq.'tcsm') then
 4273                         if(bez(myix)(8:10).eq.'3.B' .or.                &
 4274      &                  bez(myix)(8:10).eq.'3.b' .or.                   &
 4275      &                  bez(myix)(9:11).eq.'3.B' .or.                   &
 4276      &                  bez(myix)(9:11).eq.'3.b') then
 4277                                 nsig = nsig_tcsm3
 4278                         else
 4279                                 nsig = nsig_tcsm7
 4280                         endif
 4281                  elseif(bez(myix)(1:4).eq.'TCLA' .or.                   &
 4282      &           bez(myix)(1:4).eq.'tcla') then
 4283                         if(bez(myix)(9:11).eq.'7.B' .or.                &
 4284      &                  bez(myix)(9:11).eq.'7.b') then
 4285                                 nsig = nsig_tcla7
 4286                         else
 4287                                 nsig = nsig_tcla3
 4288                         endif
 4289                 elseif(bez(myix)(1:4).eq.'TCDQ' .or.                    &
 4290      &          bez(myix)(1:4).eq.'tcdq') then
 4291                         nsig = nsig_tcdq
 4292                 elseif(bez(myix)(1:4).eq.'TCTH' .or.                    &
 4293      &          bez(myix)(1:4).eq.'tcth' ) then                         &
 4294                         if(bez(myix)(8:10).eq.'1.B' .or.                &
 4295      &                  bez(myix)(8:10).eq.'1.b') then
 4296                                 nsig = nsig_tcth1
 4297                         elseif(bez(myix)(8:10).eq.'2.B' .or.            &
 4298      &                  bez(myix)(8:10).eq.'2.b') then
 4299                                 nsig = nsig_tcth2
 4300                         elseif(bez(myix)(8:10).eq.'5.B' .or.            &
 4301      &                  bez(myix)(8:10).eq.'5.b') then
 4302                                 nsig = nsig_tcth5
 4303                         elseif(bez(myix)(8:10).eq.'8.B' .or.            &
 4304      &                  bez(myix)(8:10).eq.'8.b') then
 4305                                 nsig = nsig_tcth8
 4306                         endif
 4307                 elseif(bez(myix)(1:4).eq.'TCTV' .or.                    &
 4308      &          bez(myix)(1:4).eq.'tctv' ) then
 4309                         if(bez(myix)(8:10).eq.'1.B' .or.                &
 4310      &                  bez(myix)(8:10).eq.'1.b' .or.                   &
 4311      &                  bez(myix)(9:11).eq.'1.B' .or.                   &
 4312      &                  bez(myix)(9:11).eq.'1.b' ) then
 4313                                 nsig = nsig_tctv1
 4314                         elseif(bez(myix)(8:10).eq.'2.B' .or.            &
 4315      &                  bez(myix)(8:10).eq.'2.b' .or.                   &
 4316      &                  bez(myix)(9:11).eq.'2.B' .or.                   &
 4317      &                  bez(myix)(9:11).eq.'2.b' ) then
 4318                                 nsig = nsig_tctv2
 4319                         elseif(bez(myix)(8:10).eq.'5.B' .or.            &
 4320      &                  bez(myix)(8:10).eq.'5.b' .or.                   &
 4321      &                  bez(myix)(9:11).eq.'5.B' .or.                   &
 4322      &                  bez(myix)(9:11).eq.'5.b') then
 4323                                 nsig = nsig_tctv5
 4324                         elseif(bez(myix)(8:10).eq.'8.B' .or.            &
 4325      &                  bez(myix)(8:10).eq.'8.b' .or.                   &
 4326      &                  bez(myix)(9:11).eq.'8.B' .or.                   &
 4327      &                  bez(myix)(9:11).eq.'8.b') then
 4328                                 nsig = nsig_tctv8
 4329                         endif
 4330                 elseif(bez(myix)(1:3).eq.'TDI' .or.                     &
 4331      &          bez(myix)(1:3).eq.'tdi') then
 4332                         nsig = nsig_tdi
 4333                 elseif(bez(myix)(1:4).eq.'TCLP' .or.                    &
 4334      &          bez(myix)(1:4).eq.'tclp' .or.                           &
 4335      &          bez(myix)(1:4).eq.'TCL.' .or.                           &
 4336      &          bez(myix)(1:4).eq.'tcl.') then
 4337                         nsig = nsig_tclp
 4338                 elseif(bez(myix)(1:4).eq.'TCLI' .or.                    &
 4339      &          bez(myix)(1:4).eq.'tcli') then
 4340                         nsig = nsig_tcli
 4341                 elseif(bez(myix)(1:4).eq.'TCXR' .or.                    &
 4342      &          bez(myix)(1:4).eq.'tcxr') then
 4343                         nsig = nsig_tcxrp
 4344                 elseif(bez(myix)(1:5).eq.'TCRYO' .or.                   &
 4345      &          bez(myix)(1:5).eq.'tcryo') then
 4346                         nsig = nsig_tcryo
 4347                 elseif(bez(myix)(1:3).eq.'CRY' .or.                     &
 4348      &          bez(myix)(1:3).eq.'cry') then
 4349                         nsig = nsig_cry
 4350                 elseif(bez(myix)(1:3).eq.'COL' .or.                     &
 4351      &          bez(myix)(1:3).eq.'col') then
 4352                         if(bez(myix)(1:4).eq.'COLM' .or.                &
 4353      &                  bez(myix)(1:4).eq.'colm' .or.                   &
 4354      &                  bez(myix)(1:5).eq.'COLH0' .or.                  &
 4355      &                  bez(myix)(1:5).eq.'colh0') then
 4356                                 nsig = nsig_tcth1
 4357                         elseif(bez(myix)(1:5).eq.'COLV0' .or.           &
 4358      &                  bez(myix)(1:5).eq.'colv0') then
 4359                                 nsig = nsig_tcth2
 4360                         elseif(bez(myix)(1:5).eq.'COLH1' .or.           &
 4361      &                  bez(myix)(1:5).eq.'colh1') then
 4362 !     JUNE2005   HERE WE USE NSIG_TCTH2 AS THE OPENING IN THE VERTICAL
 4363 !     JUNE2005   PLANE FOR THE PRIMARY COLLIMATOR OF RHIC; NSIG_TCTH5 STANDS
 4364 !     JUNE2005   FOR THE OPENING OF THE FIRST SECONDARY COLLIMATOR OF RHIC
 4365                                 nsig = nsig_tcth5
 4366                         elseif(bez(myix)(1:5).eq.'COLV1' .or.           &
 4367      &                  bez(myix)(1:5).eq.'colv1') then
 4368                                 nsig = nsig_tcth8
 4369                         elseif(bez(myix)(1:5).eq.'COLH2' .or.           &
 4370      &                  bez(myix)(1:5).eq.'colh2') then
 4371                         nsig = nsig_tctv1
 4372                         endif
 4373                 endif
 4374
 4375 !
 4376 !++  Write trajectory for any selected particle
 4377 !
 4378           c_length = 0d0
 4379 !
 4380 !Feb2006
 4381 !     SR, 23-11-2005: To avoid binary entries in 'amplitude.dat'
 4382        if ( firstrun ) then
 4383 !
 4384                 if (rselect.gt.0 .and. rselect.lt.65) then
 4385 !                        
 4386                         do j = 1, napx
 4387 !
 4388                                 xj     = (xv(1,j)-torbx(ie))/1d3
 4389                                 xpj    = (yv(1,j)-torbxp(ie))/1d3
 4390                                 yj     = (xv(2,j)-torby(ie))/1d3
 4391                                 ypj    = (yv(2,j)-torbyp(ie))/1d3
 4392                                 pj     = ejv(j)/1d3
 4393                                 if (iturn.eq.1.and.j.eq.1) then
 4394                                         sum_ax(ie)=0d0
 4395                                         sum_ay(ie)=0d0
 4396                                 endif
 4397                                 if (stracki.eq.0.) then
 4398                                         xj  = xj + 0.5d0*c_length*xpj
 4399                                         yj  = yj + 0.5d0*c_length*ypj
 4400                                 endif
 4401                                 gammax = (1d0 + talphax(ie)**2)/
 4402      &                          tbetax(ie)
 4403                                 gammay = (1d0 + talphay(ie)**2)/
 4404      &                          tbetay(ie)
 4405                                 if (part_abs(j).eq.0) then
 4406                                         xdebug(ie)=xj
 4407                                         xpdebug(ie)=xpj
 4408                                         ydebug(ie)=yj
 4409                                         ypdebug(ie)=ypj
 4410                                         xdebugN(ie)= xdebug(ie)
 4411      &                                  /sqrt(myemitx0*tbetax(ie))
 4412                                         xpdebugN(ie)=(xdebug(ie)*
 4413      &                                  talphax(ie)+xpdebug(ie)*
 4414      &                                  tbetax(ie))
 4415      &                                  /sqrt(myemitx0*tbetax(ie))
 4416                                         ydebugN(ie)=ydebug(ie)
 4417      &                                  /sqrt(myemity0*tbetay(ie))
 4418                                         ypdebugN(ie)=(ydebug(ie)*
 4419      &                                  talphay(ie)+ypdebug(ie)*
 4420      &                                  tbetay(ie))
 4421      &                                  /sqrt(myemity0*tbetay(ie))
 4422                                         nspx    = sqrt(                 &
 4423      &                                  abs( gammax*(xj)**2 +           &
 4424      &                                  2d0*talphax(ie)*xj*xpj +        &
 4425      &                                  tbetax(ie)*xpj**2 )/myemitx0    &
 4426      &                                  )
 4427                                         nspy    = sqrt(                 &
 4428      &                                  abs( gammay*(yj)**2 +           &
 4429      &                                  2d0*talphay(ie)*yj*ypj +        &
 4430      &                                  tbetay(ie)*ypj**2 )/myemity0    &
 4431      &                                  )
 4432                                         sum_ax(ie)   = sum_ax(ie) + nspx
 4433                                        sqsum_ax(ie)=sqsum_ax(ie)+nspx**2
 4434                                         sum_ay(ie)   = sum_ay(ie) + nspy
 4435                                        sqsum_ay(ie)=sqsum_ay(ie)+nspy**2
 4436                                         nampl(ie)    = nampl(ie) + 1
 4437                                 else
 4438                                         nspx = 0d0
 4439                                         nspy = 0d0
 4440                                 endif
 4441                                 sampl(ie)    = totals
 4442                                 ename(ie)    = bez(myix)(1:16)
 4443                         end do
 4444                 endif
 4445         endif
 4446 !GRD------------------------------------------------------------------------
 4447 !GRD HERE WE LOOK FOR ADEQUATE DATABASE INFORMATION
 4448 !GRD------------------------------------------------------------------------
 4449         found = .false.
 4450         do j = 1, db_ncoll
 4451                 if ((db_name1(j)(1:11).eq.bez(myix)(1:11)) .or.         &
 4452      &          (db_name2(j)(1:11).eq.bez(myix)(1:11))) then
 4453                         if ( db_length(j) .gt. 0d0 ) then
 4454                                 found = .true.
 4455                                 icoll = j
 4456                         endif
 4457                 endif
 4458         end do
 4459 c        if (.not. found .and. firstrun) then
 4460 c                write(*,*) 'ERR>  Collimator not found: ', bez(myix)
 4461 c        endif
 4462
 4463 !
 4464 !++ For known collimators
 4465 !
 4466         if (found) then
 4467 !-----------------------------------------------------------------------
 4468 !GRD
 4469 !GRD NEW COLLIMATION PARAMETERS
 4470 !GRD
 4471 !-----------------------------------------------------------------------
 4472 !++  Get the aperture from the beta functions and emittance
 4473 !++  A simple estimate of beta beating can be included that
 4474 !++  has twice the betatron phase advance
 4475 !
 4476 !Mars 2005
 4477                 if(.not. do_nsig) nsig = db_nsig(icoll)
 4478 !Mars 2005
 4479                 scale_bx = (1d0 + xbeat*sin(4*pi*mux(ie)+               &
 4480      &          xbeatphase)  )
 4481                 scale_by = (1d0 + ybeat*sin(4*pi*muy(ie)+               &
 4482      &          ybeatphase)  )
 4483 !
 4484                 if (firstcoll) then
 4485                         scale_bx0 = scale_bx
 4486                         scale_by0 = scale_by
 4487                         firstcoll = .false.
 4488                 endif
 4489 !
 4490 !-------------------------------------------------------------------
 4491 !++  Assign nominal OR design beta functions for later
 4492 !
 4493  
 4494                 if (do_nominal) then
 4495                         bx_dist = db_bx(icoll) * scale_bx / scale_bx0
 4496                         by_dist = db_by(icoll) * scale_by / scale_by0
 4497                 else
 4498                         bx_dist = tbetax(ie) * scale_bx / scale_bx0
 4499                         by_dist = tbetay(ie) * scale_by / scale_by0
 4500                 endif
 4501 !
 4502 !-------------------------------------------------------------------
 4503 !++  Write beam ellipse at selected collimator
 4504 ! ---- changed name_sel(1:11) name_sel(1:12) to be checked if feasible!!
 4505                 if (                                                    &
 4506      &         ((db_name1(icoll)(1:11) .eq.name_sel(1:11))              &
 4507      &         .or.(db_name2(icoll)(1:11) .eq.name_sel(1:11)))          &
 4508      &         .and. dowrite_dist) then
 4509                         do j = 1, napx
 4510                                 write(45,'(6(1X,E15.7),1X,I4,6(1X,E15.7
 4511      &                          ))') xv(1,j), xv(2,j), yv(1,j), yv(2,j), 
 4512      &                          ejv(j), mys(j),iturn,
 4513      &                          xv(1,j)/1000/sqrt(tbetax(ie)*myemitx0),  
 4514      &                          xv(2,j)/1000/sqrt(tbetay(ie)*myemity0),
 4515      &                          (xv(1,j)/1000*talphax(ie)+yv(1,j)/1000*
 4516      &                          tbetax(ie))/sqrt(tbetax(ie)*myemitx0),
 4517      &                          (xv(2,j)/1000*talphax(ie)+ yv(2,j)/1000*
 4518      &                          tbetay(ie))/sqrt(tbetay(ie)*myemity0),
 4519      &                          sqrt((xv(1,j)/1000/sqrt(tbetax(ie)*
 4520      &                          myemitx0))**2+((xv(1,j)/1000*talphax(ie)
 4521      &                          +yv(1,j)/1000*tbetax(ie))/
 4522      &                          sqrt(tbetax(ie)*myemitx0))**2)
 4523      &                          ,sqrt((xv(2,j)/1000/sqrt(tbetay(ie)*
 4524      &                          myemity0))**2+((xv(2,j)/1000*
 4525      &                          talphax(ie)+yv(2,j)/1000*tbetay(ie))/
 4526      &                          sqrt(tbetay(ie)*myemity0))**2)
 4527      &            
 4528                         end do
 4529                 endif
 4530
 4531 !
 4532 !-------------------------------------------------------------------
 4533 !++  Output to temporary database and screen
 4534 !
 4535                 if (iturn.eq.1.and.firstrun) then
 4536                         write(40,*) '# '
 4537                         write(40,*) db_name1(icoll)(1:11)
 4538                         write(40,*) db_material(icoll)
 4539                         write(40,*) db_length(icoll)
 4540                         write(40,*) db_rotation(icoll)
 4541                         write(40,*) db_offset(icoll)
 4542                         write(40,*) tbetax(ie)
 4543                         write(40,*) tbetay(ie)
 4544 !
 4545                         write(outlun,*) ' '
 4546                         write(outlun,*)   'Collimator information: '
 4547                         write(outlun,*) ' '
 4548                         write(outlun,*) 'Name:                '         &
 4549      &                  , db_name1(icoll)(1:11)
 4550                         write(outlun,*) 'Material:            '         &
 4551      &                  , db_material(icoll)
 4552                         write(outlun,*) 'Length [m]:          '         &
 4553      &                  , db_length(icoll)
 4554                          write(outlun,*) 'Rotation [rad]:     '         &
 4555      &                  , db_rotation(icoll)
 4556                         write(outlun,*) 'Offset [m]:          '         &
 4557      &                  ,db_offset(icoll)
 4558                         write(outlun,*) 'Design beta x [m]:   '         &
 4559      &                  ,db_bx(icoll)
 4560                         write(outlun,*) 'Design beta y [m]:   '         &
 4561      &                  ,db_by(icoll)
 4562                         write(outlun,*) 'Optics beta x [m]:   '         &
 4563      &                  ,tbetax(ie)
 4564                         write(outlun,*) 'Optics beta y [m]:   '         &
 4565      &                  ,tbetay(ie)
 4566                 endif
 4567 !
 4568 !-------------------------------------------------------------------
 4569 !++  Calculate aperture of collimator
 4570 !
 4571                 if(db_name1(icoll)(1:4).ne.'COLM') then
 4572                         nsig = nsig + gap_rms_error(icoll)
 4573                         xmax = nsig*sqrt(bx_dist*myemitx0)
 4574                         ymax = nsig*sqrt(by_dist*myemity0)
 4575                         xmax_pencil = (nsig+pencil_offset)*             &
 4576      &                  sqrt(bx_dist*myemitx0)
 4577                         ymax_pencil = (nsig+pencil_offset)*             &
 4578      &                  sqrt(by_dist*myemity0)
 4579                         xmax_nom = db_nsig(icoll)*sqrt(db_bx(icoll)
 4580      &                  *myemitx0)
 4581                         ymax_nom = db_nsig(icoll)*sqrt(db_by(icoll)
 4582      &                  *myemity0)
 4583                         c_rotation = db_rotation(icoll)
 4584                         c_length   = db_length(icoll)
 4585                         c_material = db_material(icoll)
 4586                         c_offset   = db_offset(icoll)
 4587                         c_tilt(1)  = db_tilt(icoll,1)
 4588                         c_tilt(2)  = db_tilt(icoll,2)
 4589 c----- valentina ---------------------------------------------      
 4590 c Orient the crystal with the beam divergence          
 4591                         if (DB_NAME1(icoll)(1:3).EQ.'CRY') then         !aligning the crystal with the divergence of the beam in that point  
 4592                                 if (DB_ROTATION(ICOLL).eq.0) then
 4593                                         Cry_tilt0= -1.*sqrt(myemitx0
 4594      &                                  /tbetax(ie))*talphaX(ie)*nsig
 4595                                 elseif (DB_ROTATION(ICOLL).GT.1.5) then !for the moment I have just hor and vertical crystals
 4596                                         Cry_tilt0 =-1.*sqrt(myemity0/
 4597      &                          tbetay(ie))*talphay(ie)* nsig
 4598                                 write(*,*) 'vertical crystal'
 4599                                 endif
 4600                         
 4601                                 Cry_length=db_length(icoll)    
 4602                                 C_xmax=db_cry_rmax(icoll)
 4603                                 C_ymax=db_cry_zmax(icoll)
 4604                                 C_orient=db_cry_orient(icoll)
 4605                                 Alayer=db_cry_alayer(icoll)
 4606                                 miscut=db_miscut(icoll)
 4607 c                                write(*,*)"from db miscut",miscut
 4608                                 Cry_tilt = DB_CRY_TILT(ICOLL)+Cry_tilt0 ! the total alignment of the crystal
 4609                                 Cry_bending=DB_LENGTH(ICOLL)
 4610      &                          /DB_CRY_RCURV(ICOLL)
 4611                                 Rcurv    = DB_CRY_RCURV(ICOLL)
 4612                                 if (Cry_tilt .ge. -Cry_bending ) then
 4613                                C_LENGTH=Rcurv*(SIN(Cry_bending+Cry_tilt)
 4614      &                  -       SIN(Cry_tilt))
 4615                                 else
 4616                                C_LENGTH=Rcurv*(SIN(Cry_bending-Cry_tilt)
 4617      &                  +       SIN(Cry_tilt))
 4618                                 endif
 4619 c                                IF(ITURN.eq.1)write(*,*)'div. @ cry: ',
 4620 c     1                          Cry_tilt0,'tilt DB:',DB_CRY_TILT(ICOLL),
 4621 c     2                          "total tilt Cry_tilt",Cry_tilt
 4622 c                                write(*,*)"debug track.f; c_length",
 4623 c     &                          C_LENGTH
 4624                               
 4625 c                               write(*,*)"crystal bending = ", Cry_bending
 4626 c                               write(*,*)"crystal lenght = ", C_LENGTH
 4627 c                               write(*,*)"cry tilt = ", Cry_tilt,"=",DB_CRY_TILT(ICOLL),
 4628 c     1                         "+",Cry_tilt0
 4629                         endif
 4630 c----------------------------------------------------------------------
 4631
 4632           
 4633                         calc_aperture =sqrt( xmax**2 *cos(c_rotation)**2
 4634      &                    + ymax**2 * sin(c_rotation)**2 )
 4635                         nom_aperture=sqrt(xmax_nom**2*cos(c_rotation)**2
 4636      &                   + ymax_nom**2 * sin(c_rotation)**2 )
 4637 !
 4638                         pencil_aperture =                              
 4639      &                       sqrt( xmax_pencil**2 * cos(c_rotation)**2  
 4640      &                       + ymax_pencil**2 * sin(c_rotation)**2 )
 4641 !
 4642 !++  Get x and y offsets at collimator center point
 4643 !
 4644                         x_pencil(icoll) = xmax_pencil *(cos(c_rotation))
 4645                         y_pencil(icoll) = ymax_pencil *(sin(c_rotation))
 4646 !
 4647 !++  Get corresponding beam angles (uses xp_max)
 4648 !
 4649                         xp_pencil(icoll) =              
 4650      &                   -1d0 * sqrt(myemitx0/tbetax(ie))*talphax(ie)  
 4651      &                   * xmax / sqrt(myemitx0*tbetax(ie))
 4652 !    
 4653                         yp_pencil(icoll) =                              
 4654      &                    -1d0 * sqrt(myemity0/tbetay(ie))*talphay(ie)  
 4655      &                   * ymax / sqrt(myemity0*tbetay(ie))
 4656 !
 4657                         xp_pencil0 = xp_pencil(icoll)
 4658                         yp_pencil0 = yp_pencil(icoll)
 4659 !
 4660                         pencil_dx(icoll)  =                            
 4661      &                      sqrt( xmax_pencil**2 * cos(c_rotation)**2  
 4662      &                      + ymax_pencil**2 * sin(c_rotation)**2 )    
 4663      &                      - calc_aperture
 4664 !++ TW -- tilt for of jaw for pencil beam
 4665 !++ as in Ralphs orig routine, but not in collimate subroutine itself
 4666 !               nprim = 3
 4667 !               if ( (icoll.eq.ipencil) &
 4668 !     &           icoll.le.nprim .and. (j.ge.(icoll-1)*nev/nprim)        &
 4669 !     &           .and. (j.le.(icoll)*nev/nprim))) then
 4670 ! this is done for every bunch (64 particle bucket)
 4671 ! important: Sixtrack calculates in "mm" and collimate2 in "m"
 4672 ! therefore 1E-3 is used to  
 4673                         if ((icoll.eq.ipencil).and.(iturn.eq.1)) then
 4674 !!                      write(*,*) " ************************************** "
 4675 !!                      write(*,*) " * INFO> seting tilt for pencil beam  * "
 4676 !!                      write(*,*) " ************************************** "
 4677                                 c_tilt(1) =c_tilt(1)+(xp_pencil0*cos(
 4678      &                          c_rotation)+sin(c_rotation)*yp_pencil0)
 4679                                 write(*,*)
 4680      &                          "INFO> Changed tilt1 ICOLL to  ANGLE: ",
 4681      &                          icoll, c_tilt(1)
 4682 !
 4683 !! respects if the tilt symmetric or not, for systilt_antiymm c_tilt is
 4684 !! -systilt + rmstilt otherwise +systilt + rmstilt
 4685 !!               if (systilt_antisymm) then
 4686 !! to align the jaw/pencil to the beam always use the minus regardless which
 4687 !! orientation of the jaws was used (symmetric/antisymmetric)
 4688                                 c_tilt(2) = c_tilt(2) -1.*(xp_pencil0
 4689      &                          *cos(c_rotation)+ sin(c_rotation)*
 4690      &                          yp_pencil0)
 4691                                 write(*,*)
 4692      &                          "INFO> Changed tilt2 ICOLL to  ANGLE: ",
 4693      &                          icoll, c_tilt(2)
 4694                         endif
 4695 !++ TW -- tilt angle changed (added to genetated on if spec. in fort.3)
 4696 !JUNE2005   HERE IS THE SPECIAL TREATMENT...
 4697                 elseif(db_name1(icoll)(1:4).eq.'COLM') then
 4698 !
 4699                         xmax = nsig_tcth1*sqrt(bx_dist*myemitx0)        
 4700 !    
 4701                         c_rotation = db_rotation(icoll)
 4702                         c_length   = db_length(icoll)
 4703                         c_material = db_material(icoll)
 4704                         c_offset   = db_offset(icoll)
 4705                         c_tilt(1)  = db_tilt(icoll,1)
 4706                         c_tilt(2)  = db_tilt(icoll,2)
 4707 !
 4708 !DEBUG
 4709 !                       calc_aperture = sqrt( xmax**2 * cos(c_rotation)**2                &
 4710 !     &                 + ymax**2 * sin(c_rotation)**2 )
 4711                         calc_aperture = xmax
 4712 !
 4713 !                       nom_aperture = sqrt( xmax**2 * cos(c_rotation-(pi/2d0))**2        &
 4714 !     &                 + ymax**2 * sin(c_rotation-(pi/2d0))**2 )
 4715                         nom_aperture = ymax
 4716 !
 4717 !DEBUG
 4718 !                       write(*,*) 'GRD'
 4719 !                       write(*,*) 'openings of colmark'
 4720 !                       write(*,*) 'hori_SIG: ',nsig_tcth1,' vert_SIG: ',nsig_tcth2
 4721 !                       write(*,*) 'xmax: ',xmax,' ymax: ',ymax
 4722 !                       write(*,*) 'trigo: ',cos(c_rotation),cos(c_rotation-(pi/2d0)),    &
 4723 !     &                 sin(c_rotation),sin(c_rotation-(pi/2d0))
 4724 !                       write(*,*) 'hori_M: ',calc_aperture,' vert_M: ',nom_aperture
 4725 !                       write(*,*) 'GRD'
 4726 !DEBUG
 4727                 endif
 4728 !
 4729 !-------------------------------------------------------------------
 4730 !++  Further output
 4731 !
 4732                 if(firstrun) then
 4733                         if (iturn.eq.1) then
 4734                                 write(outlun,*) xp_pencil(icoll),
 4735      &                          yp_pencil(icoll),pencil_dx(icoll)
 4736                                 write(outlun,'(a,i4)')
 4737      &                          'Collimator number:   ',icoll
 4738                                 write(outlun,*)
 4739      &                          'Beam size x [m]:     ',sqrt(tbetax(ie)*
 4740      &                          myemitx0)
 4741                                 write(outlun,*) 'Beam size y [m]:     ' 
 4742      &                          ,sqrt(tbetay(ie)*myemity0)
 4743                                 write(outlun,*)
 4744      &                          'Divergence x [urad]:     ',
 4745      &                          1d6*xp_pencil(icoll)
 4746                                 write(outlun,*)
 4747      &                          'Divergence y [urad]:     ',
 4748      &                          1d6*yp_pencil(icoll)
 4749                                 write(outlun,*) 'Aperture (nom) [m]:  ' 
 4750      &                          ,nom_aperture
 4751                                 write(outlun,*) 'Aperture (cal) [m]:  '
 4752      &                          ,calc_aperture
 4753                                 write(outlun,*)
 4754      &                          'Collimator halfgap [sigma]:  ',nsig
 4755                                 write(outlun,*)
 4756      &                          'RMS error on halfgap [sigma]:  '
 4757      &                          ,gap_rms_error(icoll)
 4758                                 write(outlun,*) ' '
 4759                                 write(43,'(i7.5,1x,a,4(1x,e13.5),1x,a,
 4760      &                          6(1x,e13.5))')icoll,
 4761      &                          db_name1(icoll)(1:12),db_rotation(icoll)
 4762      &                          ,tbetax(ie), tbetay(ie), calc_aperture,
 4763      &                          db_material(icoll),db_length(icoll),    
 4764      &                          sqrt(tbetax(ie)*myemitx0),
 4765      &                          sqrt(tbetay(ie)*myemity0),  
 4766      &                          db_tilt(icoll,1),db_tilt(icoll,2),  nsig
 4767                                 if ( n_slices.le.1 .or. 
 4768      &                          db_name1(icoll)(1:3) .eq. 'CRY' ) then
 4769                                 write(55,'(a,1x,i7.5,5(1x,e13.5),1x,a)')
 4770      &                                  db_name1(icoll),
 4771      &                                  1,calc_aperture,                
 4772      &                                  db_offset(icoll),
 4773      &                                  db_tilt(icoll,1),
 4774      &                                  db_tilt(icoll,2),
 4775      &                                  db_length(icoll),
 4776      &                                  db_material(icoll)
 4777                                 endif
 4778
 4779                         endif
 4780
 4781                 endif
 4782 !
 4783 !++  Assign aperture which we define as the FULL width (factor 2)!!!
 4784 !
 4785 !JUNE2005 AGAIN, SOME SPECIFIC STUFF FOR RHIC
 4786                  if(db_name1(icoll)(1:4).eq.'COLM') then
 4787                         nom_aperture = 2d0*nom_aperture
 4788                 endif
 4789                 c_aperture = 2d0*calc_aperture
 4790 !
 4791 !GRD-------------------------------------------------------------------
 4792 c      if(firstrun.and.iturn.eq.1.and.icoll.eq.7) then
 4793 c      open(unit=99,file='distsec')
 4794 c      do j=1,napx
 4795 c      write(99,'(4(1X,E15.7))') xv(1,j),yv(1,j),xv(2,j),yv(2,j)
 4796 c      enddo
 4797 c      close(99)
 4798 c      endif
 4799 !GRD-------------------------------------------------------------------
 4800 !++  Copy particle data to 1-dim array and go back to meters
 4801 !
 4802                 do j = 1, napx
 4803                         rcx(j)  = (xv(1,j)-torbx(ie))/1d3
 4804                         rcxp(j) = (yv(1,j)-torbxp(ie))/1d3
 4805                         rcy(j)  = (xv(2,j)-torby(ie))/1d3
 4806                         rcyp(j) = (yv(2,j)-torbyp(ie))/1d3
 4807                         rcp(j)  = ejv(j)/1d3
 4808                         rcs(j)  = 0d0
 4809                         part_hit_before(j) = part_hit(j)
 4810                         rcx0(j)  = rcx(j)
 4811                         rcxp0(j) = rcxp(j)
 4812                         rcy0(j)  = rcy(j)
 4813                         rcyp0(j) = rcyp(j)
 4814                         rcp0(j)  = rcp(j)
 4815                         ejf0v(j) = ejfv(j)
 4816 !
 4817 !++  For zero length element track back half collimator length
 4818 !
 4819                         if (stracki.eq.0.) then
 4820                                 rcx(j) = rcx(j) - 0.5d0*c_length*rcxp(j)
 4821                                 rcy(j)= rcy(j) - 0.5d0*c_length*rcyp(j)
 4822                         else
 4823                                 Write(*,*)
 4824      &                          "ERROR: Non-zero length collimator!"
 4825                                 STOP
 4826                         endif
 4827                         flukaname(j) = ipart(j)+100*samplenumber
 4828 !
 4829                 end do
 4830 !
 4831 !++  Do the collimation tracking
 4832 !
 4833                 enom_gev = myenom*1d-3
 4834 !
 4835 !++  Allow primaries to be one-sided, if requested
 4836 !
 4837                 if (((db_name1(icoll)(1:3).eq.'TCP' .or.            
 4838      &          db_name1(icoll)(1:3).eq.'COL' .or.
 4839      &          db_name1(icoll)(1:4).eq.'TCSP'   )                      
 4840      &          .and. do_oneside)
 4841      &          .or. (db_name1(icoll)(1:3).eq.'CRY')) then
 4842 !SEPT2008 valentina: cry is always one sided
 4843                         onesided = .true.
 4844                 else
 4845                         onesided = .false.
 4846                 endif
 4847 !
 4848 !Force the treatment of the TCDQ equipment as a onsided collimator.
 4849 !Both for Beam 1 and Beam 2, the TCDQ is at positive x side.
 4850 !              if(db_name1(icoll)(1:4).eq.'TCDQ' ) onesided = .true.
 4851 ! to treat all collimators onesided
 4852 ! -> only for worst case TCDQ studies
 4853                 if(db_name1(icoll)(1:5).eq.'TCXRP') onesided = .true.
 4854                 if(db_name1(icoll)(1:11).eq.'TCP.1MM.EXP')
 4855      1              onesided = .true.    !scraper for the UA9 experiment
 4856                 if(db_name1(icoll)(1:4).eq.'TCDQ') onesided = .true.
 4857 !
 4858                 if (found) then
 4859 !
 4860                         if(db_name1(icoll)(1:4).eq.'COLM') then
 4861 !
 4862                                         call collimaterhic(c_material,  
 4863      &                                  c_length, c_rotation,          
 4864      &                                  c_aperture, nom_aperture,      
 4865      &                                  c_offset, c_tilt,              
 4866      &                                  rcx, rcxp, rcy, rcyp, rcp, rcs,
 4867      &                                  napx,enom_gev,part_hit,part_abs,
 4868      &                                  part_impact, part_indiv,
 4869      &                                  part_linteract, onesided,      
 4870      &                                  flukaname)
 4871                                         
 4872 !-------     valentina   SEPT 2008------------------------------
 4873 ! add crystal collimation routine
 4874                                         
 4875                         elseif (db_name1(icoll)(1:3).eq.'CRY') then
 4876 c                        write(*,*)"debug miscut collimate",miscut
 4877                                 call collimate_cry ( db_name1(icoll) ,
 4878      &                           C_MATERIAL, C_LENGTH, C_ROTATION,
 4879      1                          C_APERTURE, C_OFFSET, C_TILT,
 4880      1                          rcx, rcxp, rcy, rcyp, rcp, rcs,
 4881      2                          napx,enom_gev, part_hit,
 4882      3                          PART_ABS, part_impact, part_indiv,
 4883      &                          part_linteract,tbetax(ie),talphax(ie),
 4884      &                          tbetay(ie),talphay(ie),EMITX0,EMITY0,
 4885      6                          flukaname, secondary,dowrite_impact)  
 4886 c------------- ----------- ------------------------- ----------
 4887 !SEPT2008 JCSMITH
 4888 ! add in electron lense collimator
 4889                         elseif (db_name1(icoll)(1:5).eq.'ELENS') then
 4890                                 call collimate_elense (
 4891      &                          db_elense_thickness(icoll),
 4892      &                          db_elense_j_e(icoll),c_length,c_rotation
 4893      &                          ,c_aperture, c_offset, c_tilt, rcx, rcxp
 4894      &                          ,rcy, rcyp,rcp, rcs, napx, enom_gev,
 4895      &                          part_hit, part_abs, part_impact,
 4896      &                          part_indiv, part_linteract, flukaname)
 4897 !
 4898 !     SR, 29-08-2005: Slice the collimator jaws in 'n_slices' pieces
 4899 !     using two 4th-order polynomial fits. For each slices, the new
 4900 !     gaps and centre are calculates
 4901 !     It is assumed that the jaw point closer to the beam defines the
 4902 !     nominal aperture.
 4903 !
 4904 !     SR, 01-09-2005: new official version - input assigned through
 4905 !     the 'fort.3' file.
 4906 !CB
 4907                         elseif (n_slices.gt.1d0 .and.
 4908      &                  (db_name1(icoll)(1:4).eq.'TCSG'
 4909      &                  .or. db_name1(icoll)(1:3).eq.'TCP' 
 4910      &                  .or. db_name1(icoll)(1:4).eq.'TCLA'
 4911      &                  .or. db_name1(icoll)(1:3).eq.'TCT' 
 4912      &                  .or. db_name1(icoll)(1:4).eq.'TCLI' 
 4913      &                  .or. db_name1(icoll)(1:4).eq.'TCSP' 
 4914      &                  .or. db_name1(icoll)(1:4).eq.'TCL.')) then      
 4915                                 if (firstrun) then
 4916                                         write(*,*)
 4917      &                                  'INFO> slice - Collimator ',
 4918      &                                  db_name1(icoll), ' sliced in ',
 4919      &                                  n_slices,' pieces!'
 4920                                 endif
 4921 !!     In this preliminary try, all secondary collimators are sliced.
 4922 !!     Slice only collimators with finite length!!
 4923 !!     Slice the primaries, to have more statistics faster!
 4924 !!
 4925 !!     Calculate longitudinal positions of slices and corresponding heights
 4926 !!     and angles from the fit parameters.
 4927 !!     -> MY NOTATION: y1_sl: jaw at x > 0; y2_sl: jaw at x < 0;
 4928 !!     Note: here, take (n_slices+1) points in order to calculate the
 4929 !!           tilt angle of the last slice!!
 4930 !     CB:10-2007 deformation of the jaws scaled with length
 4931                                 do jjj=1,n_slices+1
 4932                                         x_sl(jjj) = (jjj-1) * c_length/
 4933      &                                  dble(n_slices)
 4934                                         y1_sl(jjj) =  fit1_1 +
 4935      &                                  fit1_2*x_sl(jjj) +
 4936      &                                  fit1_3/c_length*(x_sl(jjj)**2)+
 4937      &                                  fit1_4*(x_sl(jjj)**3) +
 4938      &                                  fit1_5*(x_sl(jjj)**4) +
 4939      &                                  fit1_6*(x_sl(jjj)**5)
 4940 !    
 4941                                         y2_sl(jjj) = -1d0 * (fit2_1 +
 4942      &                                  fit2_2*x_sl(jjj) +
 4943      &                                  fit2_3/c_length*(x_sl(jjj)**2)+
 4944      &                                  fit2_4*(x_sl(jjj)**3) +
 4945      &                                  fit2_5*(x_sl(jjj)**4) +
 4946      &                                  fit2_6*(x_sl(jjj)**5))
 4947                                 enddo
 4948 !     Apply the slicing scaling factors (ssf's):
 4949 !    
 4950 !                               do jjj=1,n_slices+1
 4951 !                                        y1_sl(jjj) = ssf1 * y1_sl(jjj)
 4952 !                                        y2_sl(jjj) = ssf2 * y2_sl(jjj)
 4953 !                               enddo
 4954 !
 4955 !     CB:10-2007 coordinates rotated of the tilt
 4956                                 do jjj=1,n_slices+1
 4957                                         y1_sl(jjj) = ssf1 * y1_sl(jjj)
 4958                                         y2_sl(jjj) = ssf2 * y2_sl(jjj)
 4959 ! CB code
 4960                                         x1_sl(jjj)=x_sl(jjj)*
 4961      &                                  cos(db_tilt(icoll,1))- 
 4962      &                                  y1_sl(jjj)*sin(db_tilt(icoll,1))
 4963                                         x2_sl(jjj)=x_sl(jjj)*
 4964      &                                  cos(db_tilt(icoll,2))- 
 4965      &                                  y2_sl(jjj)*sin(db_tilt(icoll,2))
 4966                                         y1_sl(jjj) = y1_sl(jjj)*
 4967      &                                  cos(db_tilt(icoll,1))+ 
 4968      &                                  x_sl(jjj)*sin(db_tilt(icoll,1))
 4969                                         y2_sl(jjj) = y2_sl(jjj)*
 4970      &                                  cos(db_tilt(icoll,2))+ 
 4971      &                                  x_sl(jjj)*sin(db_tilt(icoll,2))
 4972                                 enddo
 4973 !     Sign of the angle defined differently for the two jaws!
 4974                                 do jjj=1,n_slices
 4975                                         angle1(jjj) = ((y1_sl(jjj+1)-
 4976      &                                  y1_sl(jjj))
 4977      &                                  /( x1_sl(jjj+1)-x1_sl(jjj) ))
 4978                                         angle2(jjj) =(( y2_sl(jjj+1)-
 4979      &                                  y2_sl(jjj))
 4980      &                                  /( x2_sl(jjj+1)-x2_sl(jjj) ))
 4981                                 enddo
 4982 !
 4983 !     Sign of the angle defined differently for the two jaws!
 4984 !     For both jaws, look for the 'deepest' point (closest point to beam)
 4985 !     Then, shift the vectors such that this closest point defines
 4986 !     the nominal aperture
 4987 !     Index here must go up to (n_slices+1) in case the last point is the
 4988 !     closest (and also for the later calculation of 'a_tmp1' and 'a_tmp2')
 4989 !
 4990 !     SR, 01-09-2005: add the recentring flag, as given in 'fort.3' to
 4991 !     choose whether recentre the deepest point or not
 4992                                 max_tmp = 1e6
 4993                                 do jjj=1, n_slices+1
 4994                                         if ( y1_sl(jjj).lt.max_tmp )then
 4995                                                 max_tmp = y1_sl(jjj)
 4996                                         endif
 4997                                 enddo
 4998                                 do jjj=1, n_slices+1
 4999                                         y1_sl(jjj) = y1_sl(jjj) -max_tmp
 5000      &                                  * recenter1+ 0.5 *c_aperture
 5001                                 enddo
 5002                                 max_tmp = -1e6
 5003                                 do jjj=1, n_slices+1
 5004                                         if ( y2_sl(jjj).gt.max_tmp )then
 5005                                                 max_tmp = y2_sl(jjj)
 5006                                         endif
 5007                                 enddo
 5008                                 do jjj=1, n_slices+1
 5009                                         y2_sl(jjj) = y2_sl(jjj) -max_tmp
 5010      &                                  * recenter2- 0.5 *c_aperture
 5011                                 enddo
 5012 !
 5013 !!     Check the collimator jaw surfaces (beam frame, before taking into
 5014 !!     account the azimuthal angle of the collimator)
 5015                                 if (firstrun)  write(*,*)
 5016      &                          'Slicing collimator ',db_name1(icoll)
 5017                                 
 5018 !
 5019 !     Now, loop over the number of slices and call collimate2 each time!
 5020 !     For each slice, the corresponding offset and angle are to be used.
 5021                                 do jjj=1,n_slices
 5022 !
 5023 !     First calculate aperture and centre of the slice
 5024 !     Note that:
 5025 !     (1)due to our notation for the angle sign,
 5026 !     the rotation point of the slice (index j or j+1)
 5027 !     DEPENDS on the angle value!!
 5028 !     (2) New version of 'collimate2' is required: one must pass
 5029 !     the slice number in order the calculate correctly the 's'
 5030 !     coordinate in the impact files.
 5031 !
 5032 !     Here, 'a_tmp1' and 'a_tmp2' are, for each slice, the closest
 5033 !     corners to the beam
 5034                                         if ( angle1(jjj).gt.0d0 ) then
 5035                                                 a_tmp1 = y1_sl(jjj)
 5036                                         else
 5037                                                 a_tmp1 = y1_sl(jjj+1)
 5038                                         endif
 5039                                         if ( angle2(jjj).lt.0d0 ) then
 5040                                                 a_tmp2 = y2_sl(jjj)
 5041                                         else
 5042                                                 a_tmp2 = y2_sl(jjj+1)
 5043                                         endif
 5044 !!     Write down the information on slice centre and offset
 5045 !!
 5046 !     Be careful! the initial tilt must be added!
 5047 !     We leave it like this for the moment (no initial tilt)
 5048 !                                       c_tilt(1) = c_tilt(1) + angle1(jjj)
 5049 !                                       c_tilt(2) = c_tilt(2) + angle2(jjj)
 5050                                         c_tilt(1) = angle1(jjj)
 5051                                         c_tilt(2) = angle2(jjj)
 5052 !     New version of 'collimate2' is required: one must pass the
 5053 !     slice number in order the calculate correctly the 's'
 5054 !     coordinate in the impact files.
 5055 !     +                                 a_tmp1 - a_tmp2,
 5056 !     +                                 0.5 * ( a_tmp1 + a_tmp2 ),
 5057 ! -- TW SEP07 added compatility for tilt, gap and ofset errors to slicing
 5058 ! -- TW gaprms error is already included in the c_aperture used above  
 5059 ! -- TW tilt error is added to y1_sl and y2_sl therfore included in
 5060 ! -- TW angle1 and angle2 no additinal changes needed
 5061 ! -- TW offset error directly added to call of collimate2
 5062                                         if (firstrun) then
 5063                                                 write(55,'(a,1x,i7.5,
 5064      &                                          5(1x,e13.5),1x ,a)')
 5065      &                                          db_name1(icoll)(1:12),
 5066      &                                          jjj,(a_tmp1 - a_tmp2)  
 5067      &                                          /2d0,0.5*(a_tmp1+a_tmp2)
 5068      &                                          +c_offset, c_tilt(1),
 5069      &                                          c_tilt(2),        
 5070      &                                          c_length/dble(n_slices),
 5071      &                                          db_material(icoll)
 5072                                         endif
 5073                                         name_coll=db_name1(icoll)
 5074                                         call collimate2(name_coll,
 5075      &                                  c_material,
 5076      &                                  c_length/dble(n_slices),
 5077      &                                  c_rotation, a_tmp1 - a_tmp2,
 5078      &                                  0.5 * ( a_tmp1 + a_tmp2 )
 5079      &                                  + c_offset,   c_tilt, rcx, rcxp,
 5080      &                                  rcy, rcyp,rcp, rcs, napx,
 5081      &                                  enom_gev,part_hit, part_abs,
 5082      &                                  part_impact, part_indiv,  
 5083      &                                  part_linteract, onesided,
 5084      &                                  flukaname,secondary, jjj)
 5085                                 enddo
 5086                         else
 5087 !     Treatment of non-sliced collimators!
 5088                                 name_coll=db_name1(icoll)
 5089                                 call collimate2(name_coll,
 5090      &                          c_material, c_length, c_rotation,
 5091      &                          c_aperture, c_offset, c_tilt, rcx, rcxp,
 5092      &                          rcy, rcyp,rcp, rcs, napx, enom_gev,
 5093      &                          part_hit, part_abs, part_impact,
 5094      &                          part_indiv, part_linteract,        
 5095      &                          onesided, flukaname, secondary, 1)
 5096                          endif
 5097 ! end of check for 'found'
 5098                 endif
 5099 !++  Output information:
 5100 !++  PART_HIT(MAX_NPART)     Hit flag for last hit (10000*element# + turn#)
 5101 !++  PART_ABS(MAX_NPART)     Abs flag (10000*element# + turn#)
 5102 !++  PART_IMPACT(MAX_NPART)  Impact parameter (0 for inner face)
 5103 !++  PART_INDIV(MAX_NPART)   Divergence of impacting particles
 5104 !------------------------------------------------------------------------------
 5105 !++  Calculate average impact parameter and save info for all
 5106 !++  collimators. Copy information back and do negative drift.
 5107                 n_impact = 0
 5108                 n_absorbed = 0
 5109                 sum      = 0d0
 5110                 sqsum    = 0d0
 5111 !++  Copy particle data back and do path length stuff; check for absorption
 5112 !++  Add orbit offset back.
 5113                 do j = 1, napx
 5114 !APRIL2005 IN ORDER TO GET RID OF NUMERICAL ERRORS, JUST DO THE TREATMENT FOR
 5115 !APRIL2005 IMPACTING PARTICLES...
 5116                         if (part_hit(j).eq.(10000*ie+iturn)) then
 5117 !++  For zero length element track back half collimator length
 5118                                 if (stracki.eq.0.) then
 5119                                         rcx(j)  = rcx(j) - 
 5120      &                                  0.5d0*c_length*rcxp(j)
 5121                                         rcy(j)  = rcy(j) - 
 5122      &                                  0.5d0*c_length*rcyp(j)
 5123                                 endif
 5124 c------------------write initial-final coordinates for crystal -----------------------
 5125 !SEPT2008 valentina: write special output files for cry
 5126                                 if (write_c_out  .and.
 5127      1                          DB_NAME1(ICOLL)(1:3).EQ.'CRY'
 5128      1                          ) THEN  
 5129 c-                                      initial coordinatesi
 5130                                         WRITE(881,'(i7,i4,2x,i4,2x,i4,
 5131      &                                  2x,a,2x,5(f15.8,2x))')
 5132      1                                  ipart(j)+100*samplenumber,ITURN,
 5133      &                                  bool_proc_old(j),ICOLL,
 5134      2                                  DB_MATERIAL(ICOLL),rcx0(J),
 5135      &                                 rcxp0(J),rcy0(j),rcyp0(J),rcP0(J)!write down real and noormalized coordinates
 5136      2                                                                  !before and after the crystal
 5137                                         X_NORM=rcx0(J)/ SQRT(tbetax(ie))
 5138      &                                  /sqrt(myEMITX0)
 5139                                         XP_NORM=(rcx0(J)*talphax(IE) + 
 5140      &                                  rcxp0(J)*tbetax(IE))/
 5141      1                                  SQRT(tbetax(ie))/ sqrt(myEMITX0)
 5142                                         Y_NORM=rcY0(J)/ SQRT(tbetay(ie))
 5143      &                                  /sqrt(myEMITY0)
 5144                                         YP_NORM=(rcY0(J)*talphay(IE) + 
 5145      &                                  rcyp0(J)*tbetay(IE))/
 5146      1                                  SQRT(tbetay(ie))/ sqrt(myEMITY0)
 5147
 5148                                         WRITE(883,'(i7,i4,2x,i4,2x,i4,2x
 5149      &                                  ,a,2x,7(f15.8,2x))')
 5150      2                                  ipart(j)+100*samplenumber,ITURN,
 5151      &                                  bool_proc_old(j),ICOLL,
 5152      3                                  DB_MATERIAL(ICOLL),X_NORM,
 5153      &                                  XP_NORM,Y_NORM,YP_NORM,
 5154      &                                  SQRT(X_NORM**2+XP_NORM**2),
 5155      5                                  SQRT(Y_NORM**2+YP_NORM**2),
 5156      &                                  rcP0(j)
 5157                                         if (part_abs(j) .eq. 0) then 
 5158                                           WRITE(882,'(i7,4(i4,2x)
 5159      &                                    ,a,2x,5(f15.8,2x))')
 5160      1                                    ipart(j)+100*samplenumber,
 5161      2                                    ITURN,bool_proc_old(j),
 5162      &                                    bool_proc(j),ICOLL,
 5163      2                                    DB_MATERIAL(ICOLL),rcX(J),
 5164      2                                    rcXP(J),rcY(J),rcYP(J),rcP(J)
 5165 c
 5166                                           X_NORM =rcX(J)/SQRT(tbetax(ie)
 5167      &                                     )/sqrt(myEMITX0)
 5168                                           XP_NORM = (rcX(J)*talphax(IE)+
 5169      &                                     rcXP(J)*tbetax(IE))/SQRT(
 5170      1                                     tbetax(ie))/ sqrt(myEMITX0)
 5171                                           Y_NORM =rcY(J)/SQRT(tbetay(ie)
 5172      &                                     )/sqrt(myEMITY0)
 5173                                           YP_NORM = (rcY(J)*talphay(IE)+ 
 5174      &                                    rcYP(J)*tbetay(IE))/SQRT(
 5175      1                                     tbetay(ie))/ sqrt(myEMITY0)
 5176             
 5177                                           WRITE(884,'(i7,4(i4,2x),a,2x,
 5178      &                                    7(f15.8,2x))') ipart(j)+100*
 5179      &                                    samplenumber, ITURN ,
 5180      &                                    bool_proc_old(j),bool_proc(j),
 5181      3                                    ICOLL,DB_MATERIAL(ICOLL)
 5182      3                                    ,X_NORM,XP_NORM, Y_NORM,    
 5183      3                                    YP_NORM,SQRT(X_NORM**2+
 5184      &                                    XP_NORM**2),SQRT(Y_NORM**2+
 5185      4                                    YP_NORM**2), rcP(j)
 5186
 5187                                           write(885,*)
 5188      1                                    ipart(j)+100*samplenumber,
 5189      2                                    ITURN,bool_proc_old(j),
 5190      &                                    bool_proc(j),ICOLL,
 5191      2                                    DB_MATERIAL(ICOLL),
 5192      &                                    rcx0(J),rcxp0(J),
 5193      &                                    rcy0(J),rcyp0(J),!write down real and noormalized coordinates
 5194      &                                    rcXP(J)-rcXP0(J),
 5195      &                                    rcYP(J)-rcYP0(J),
 5196      &                                    rcp0(J)-rcp(j),
 5197      &                                    c_aperture,cry_tilt0
 5198                                         endif
 5199                                 endif
 5200 c--------------------------------------------------------------------------
 5201 c
 5202               
 5203 !++  Now copy data back to original verctor
 5204  
 5205                                 xv(1,j) = rcx(j)*1d3  +torbx(ie)
 5206                                 yv(1,j) = rcxp(j)*1d3 +torbxp(ie)
 5207                                 xv(2,j) = rcy(j)*1d3  +torby(ie)
 5208                                 yv(2,j) = rcyp(j)*1d3 +torbyp(ie)
 5209                                 ejv(j) = rcp(j)*1d3
 5210 !
 5211 !
 5212 !++  Energy update, as recommended by Frank
 5213 !
 5214                                 ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
 5215                                 rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
 5216                                 dpsv(j)=(ejfv(j)-e0f)/e0f
 5217                                 oidpsv(j)=one/(one+dpsv(j))
 5218                                 dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
 5219                                 yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
 5220                                 yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
 5221 !APRIL2005 ...OTHERWISE JUST GET BACK FORMER COORDINATES
 5222                         else
 5223                                 xv(1,j) = rcx0(j)*1d3+torbx(ie)
 5224                                 yv(1,j) = rcxp0(j)*1d3+torbxp(ie)
 5225                                 xv(2,j) = rcy0(j)*1d3+torby(ie)
 5226                                 yv(2,j) = rcyp0(j)*1d3+torbyp(ie)
 5227                                 ejv(j) = rcp0(j)*1d3
 5228                         endif
 5229 !
 5230 !++  Write trajectory for any selected particle
 5231 !
 5232                         if (firstrun) then
 5233                         if (rselect.gt.0 .and. rselect.lt.65) then
 5234                                 xj     = (xv(1,j)-torbx(ie))/1d3
 5235                                 xpj    = (yv(1,j)-torbxp(ie))/1d3
 5236                                 yj     = (xv(2,j)-torby(ie))/1d3
 5237                                 ypj    = (yv(2,j)-torbyp(ie))/1d3
 5238                                 pj     = ejv(j)/1d3
 5239                                         if (iturn.eq.1.and.j.eq.1) then
 5240                                                 sum_ax(ie)=0d0
 5241                                                 sum_ay(ie)=0d0
 5242                                         endif
 5243                                 gammax=(1d0 + talphax(ie)**2)/tbetax(ie)
 5244                                 gammay=(1d0 + talphay(ie)**2)/tbetay(ie)
 5245                                 if (part_abs(j).eq.0) then
 5246                                         xdebug(ie)=xj
 5247                                         xpdebug(ie)=xpj
 5248                                         ydebug(ie)=yj
 5249                                         ypdebug(ie)=ypj
 5250                                         xdebugN(ie)= xdebug(ie)
 5251      &                                  /sqrt(myemitx0*tbetax(ie))
 5252                                         xpdebugN(ie)=(xdebug(ie)
 5253      &                              *talphax(ie)+xpdebug(ie)*tbetax(ie))
 5254      &                                  /sqrt(myemitx0*tbetax(ie))
 5255                                         ydebugN(ie)=ydebug(ie)/sqrt(
 5256      &                                  myemity0*tbetay(ie))
 5257                                         ypdebugN(ie)=(ydebug(ie)*
 5258      &                                  talphay(ie)+ypdebug(ie)*
 5259      &                                  tbetay(ie))
 5260      &                                  /sqrt(myemity0*tbetay(ie))
 5261           
 5262                                         nspx    = sqrt(
 5263      &                                  abs( gammax*(xj)**2 +  
 5264      &                                  2d0*talphax(ie)*xj*xpj +
 5265      &                                  tbetax(ie)*xpj**2 )/myemitx0)  
 5266                                         nspy    = sqrt(
 5267      &                                  abs( gammay*(yj)**2 +  
 5268      &                                  2d0*talphay(ie)*yj*ypj +
 5269      &                                  tbetay(ie)*ypj**2 )/myemity0)
 5270                                         sum_ax(ie)   = sum_ax(ie) + nspx
 5271                                        sqsum_ax(ie)=sqsum_ax(ie)+nspx**2
 5272                                        sum_ay(ie)   = sum_ay(ie) + nspy
 5273                                        sqsum_ay(ie)=sqsum_ay(ie)+nspy**2
 5274                                         nampl(ie)    = nampl(ie) + 1
 5275                                 else
 5276                                         nspx = 0d0
 5277                                         nspy = 0d0
 5278                                 endif
 5279                                 sampl(ie)    = totals
 5280                                 ename(ie)    = bez(myix)(1:16)
 5281                         endif
 5282                         endif
 5283 !++  First check for particle interaction at this collimator and this turn
 5284                         if (part_hit(j).eq. (10000*ie+iturn)) then
 5285 !++  Fill the change in particle angle into histogram
 5286                                 if(dowrite_impact) then
 5287                                   write(46,'(i8,1x,i4,1x,f8.2)')ipart(j)
 5288      &                            +100*samplenumber,iturn,sampl(ie)
 5289                                 endif
 5290                                 if(part_abs(j).ne.0) then
 5291                                   if(dowrite_impact)
 5292      &                            write(47,'(i8,1x,i4,1x,f8.2)')        
 5293      &                            ipart(j)+100*samplenumber,iturn,
 5294      &                            sampl(ie)
 5295                                   write(38,'(1x,i8,1x,i4,1x,f8.2,
 5296      &                            5(1x,e11.3),1x,i4)')
 5297      &                            ipart(j)+100*samplenumber,iturn,
 5298      &                            sampl(ie)-0.5*c_length,          
 5299      &                            (rcx0(j)*1d3+torbx(ie))-0.5*c_length*
 5300      &                            (rcxp0(j)*1d3+torbxp(ie)),  
 5301      &                            rcxp0(j)*1d3+torbxp(ie),
 5302      &                            (rcy0(j)*1d3+torby(ie))-0.5*c_length*
 5303      &                            (rcyp0(j)*1d3+torbyp(ie)),  
 5304      &                            rcyp0(j)*1d3+torbyp(ie),
 5305      &                            (ejv(j)-myenom)/myenom,secondary(j)+
 5306      &                            tertiary(j)+other(j)
 5307                                 endif
 5308                                 if (part_abs(j).eq.0) then
 5309                                   xkick = rcxp(j) - rcxp0(j)
 5310                                   ykick = rcyp(j) - rcyp0(j)
 5311 !
 5312                                   if (db_name1(icoll)(1:3).eq.'TCP'.or. 
 5313      &                            db_name1(icoll)(1:4).eq.'COLM'.or.    
 5314      &                            db_name1(icoll)(1:5).eq.'COLH0'.or.  
 5315      &                            db_name1(icoll)(1:5).eq.'COLV0') then
 5316                                         secondary(j) = 1
 5317                                   elseif(db_name1(icoll)(1:3).eq.'TCS'
 5318      &                           .or.db_name1(icoll)(1:4).eq.'COLH1'.or. 
 5319      &                            db_name1(icoll)(1:4).eq.'COLV1'.or.  
 5320      &                            db_name1(icoll)(1:4).eq.'COLH2') then
 5321                                         tertiary(j)  = 2
 5322                                   elseif((db_name1(icoll)(1:3).eq.'TCL')
 5323      &                           .or.(db_name1(icoll)(1:3).eq.'TCT').or. 
 5324      &                            (db_name1(icoll)(1:3).eq.'TCD').or.  
 5325      &                            (db_name1(icoll)(1:3).eq.'TDI')) then
 5326                                         other(j)     = 4
 5327                                   endif
 5328                                 endif
 5329 !
 5330 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!!
 5331                                 if (dowritetracks) then
 5332                                   if(part_abs(j).eq.0) then
 5333                                         if ((secondary(j).eq.1.or.
 5334      &                                  tertiary(j).eq.2.or.other(j)
 5335      &                                  .eq.4) .and.
 5336      &                                  (xv(1,j).lt.99d0 .and. xv(2,j)
 5337      &                                  .lt.99d0)
 5338      &                                  .and. 
 5339 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
 5340      &                                  (            
 5341      &                                  ((              
 5342      &                                  (xv(1,j)*1d-3)**2    
 5343      &                                  /(tbetax(ie)*myemitx0)    
 5344      &                                  ).ge.dble(sigsecut2)).or.  
 5345      &                                  ((                            
 5346      &                                  (xv(2,j)*1d-3)**2            
 5347      &                                  /(tbetay(ie)*myemity0)          
 5348      &                                  ).ge.dble(sigsecut2)).or.      
 5349      &                                  (((xv(1,j)*1d-3)**2/(tbetax(ie)*
 5350      &                                  myemitx0))+((xv(2,j)*1d-3)**2/
 5351      &                                  (tbetay(ie)*myemity0))
 5352      &                                  .ge.sigsecut3)  
 5353      &                                  ) ) then
 5354                                              xj=(xv(1,j)-torbx(ie))/1d3
 5355                                              xpj=(yv(1,j)-torbxp(ie))
 5356      &                                       /1d3
 5357                                              yj=(xv(2,j)-torby(ie))/1d3
 5358                                              ypj=(yv(2,j)-torbyp(ie))
 5359      &                                       /1d3
 5360                                              write(38,'(1x,i8,1x,i4,1x,
 5361      &                                       f8.2,5(1x,e11.3),1x,i4)')
 5362      &                                       ipart(j)+100*samplenumber,
 5363      &                                       iturn,sampl(ie)-0.5*
 5364      &                                       c_length,
 5365      &                                       (rcx0(j)*1d3+torbx(ie))-0.5
 5366      &                                       *c_length*(rcxp0(j)*1d3+
 5367      &                                       torbxp(ie)),  
 5368      &                                       rcxp0(j)*1d3+torbxp(ie),  
 5369      &                                       (rcy0(j)*1d3+torby(ie))-0.5
 5370      &                                       *c_length*(rcyp0(j)*1d3+
 5371      &                                       torbyp(ie)),rcyp0(j)*1d3+
 5372      &                                       torbyp(ie),                
 5373      &                                       (ejv(j)-myenom)/myenom,
 5374      &                                       secondary(j)+tertiary(j)+
 5375      &                                       other(j)
 5376                                              write(38,'(1x,i8,1x,i4,1x,
 5377      &                                       f8.2,5(1x,e11.3),1x,i4)')  
 5378      &                                       ipart(j)+100*samplenumber,
 5379      &                                       iturn,sampl(ie)+0.5*
 5380      &                                       c_length,xv(1,j)+0.5
 5381      &                                       *c_length*yv(1,j),yv(1,j),
 5382      &                                       xv(2,j)+0.5*c_length*
 5383      &                                       yv(2,j),yv(2,j),
 5384      &                                       (ejv(j)-myenom)/myenom,
 5385      &                                       secondary(j)+tertiary(j)
 5386      &                                       +other(j)
 5387                                        endif
 5388                                   endif
 5389                                 endif
 5390 !++  Calculate impact observables, fill histograms, save collimator info, ...
 5391 ! OCT2008 JCSMITH
 5392 ! There's something wrong here I'll try to fix it...
 5393                                 if (abs(part_impact(j)) .lt. 0.9) then
 5394                                   n_impact = n_impact + 1
 5395                                   sum = sum + abs(part_impact(j))
 5396                                   sqsum = sqsum + abs(part_impact(j))**2
 5397                                   cn_impact(icoll) = cn_impact(icoll)+1
 5398                                   csum(icoll) = csum(icoll) + 
 5399      &                            abs(part_impact(j))
 5400                                   csqsum(icoll) = csqsum(icoll) +
 5401      &                            abs(part_impact(j))**2
 5402                                 endif
 5403 !++  If the interacting particle was lost, add-up counters for absorption
 5404 !++  Note: a particle with x/y >= 99. never hits anything any more in
 5405 !++        the logic of this program. Be careful to always fulfill this!
 5406 !
 5407                                 if (part_abs(j).ne.0) then
 5408                                   n_absorbed = n_absorbed + 1
 5409                                  cn_absorbed(icoll)=cn_absorbed(icoll)+1
 5410                                   n_tot_absorbed = n_tot_absorbed + 1
 5411                                   iturn_last_hit = part_hit_before(j)- 
 5412      &                             int(part_hit_before(j)/10000)*10000
 5413                                   iturn_absorbed = part_hit(j)- 
 5414      &                             int(part_hit(j)/10000)*10000
 5415                                   if (iturn_last_hit.eq.0)
 5416      &                            iturn_last_hit =iturn_absorbed
 5417                                   iturn_survive  = iturn_absorbed - 
 5418      &                             iturn_last_hit
 5419                                 endif
 5420 !++  End of check for hit this turn and element
 5421                         endif
 5422 !++  Now copy the new particle momenta
 5423                 end do
 5424 !++  Calculate statistical observables and save into files...
 5425                 if (n_impact.gt.0) then
 5426                         average = sum/n_impact
 5427                         if (sqsum/n_impact.ge.average**2) then
 5428                                 sigma =sqrt(sqsum/n_impact - average**2)
 5429                         else
 5430                                 sigma = 0d0
 5431                         endif
 5432                 else
 5433                         average = 0d0
 5434                         sigma   = 0d0
 5435                 endif
 5436                 if (cn_impact(icoll).gt.0) then
 5437                         caverage(icoll) = csum(icoll)/cn_impact(icoll)
 5438                         if ((caverage(icoll)**2).gt.                    
 5439      &                  (csqsum(icoll)/cn_impact(icoll))) then
 5440                                 csigma(icoll) = 0
 5441                         else
 5442                                 csigma(icoll) = sqrt(csqsum(icoll)/    
 5443      &                          cn_impact(icoll) - caverage(icoll)**2)
 5444                         endif
 5445                 endif
 5446 !
 5447 !-----------------------------------------------------------------
 5448 !++  For a  S E L E C T E D  collimator only consider particles that
 5449 !++  were scattered on this selected collimator at the first turn. All
 5450 !++  other particles are discarded.
 5451 !++  - This is switched on with the DO_SELECT flag in the input file.
 5452 !++  - Note that the part_select(j) flag defaults to 1 for all particles.
 5453 !
 5454 ! should name_sel(1:11) extended to allow longer names as done for
 5455 ! coll the coll_ellipse.dat file !!!!!!!!
 5456                 if (((db_name1(icoll)(1:10).eq.name_sel(1:10) )
 5457      &          .or.(db_name2(icoll)(1:10).eq.name_sel(1:10) ) )      
 5458      &          .and. iturn.eq.1  ) then
 5459                         num_selhit = 0
 5460                         num_surhit = 0
 5461                         num_selabs = 0
 5462                         do j = 1, napx
 5463                                 if(part_hit(j).eq.(10000*ie+iturn))then
 5464                                         num_selhit = num_selhit+1
 5465                                         if (part_abs(j).eq.0) then
 5466                                                num_surhit = num_surhit+1
 5467                                         else
 5468                                         num_selabs = num_selabs + 1
 5469                                         endif
 5470 !++  If we want to select only partciles interacting at the specified
 5471 !++  collimator then remove all other particles and reset the number
 5472 !++  of the absorbed particles to the selected collimator.
 5473                                 endif
 5474                         end do
 5475 !++  Calculate average impact parameter and save distribution into file
 5476 !++  only for selected collimator
 5477                         n_impact = 0
 5478                         sum      = 0d0
 5479                         sqsum    = 0d0
 5480                         do j = 1, napx
 5481                                 if(part_hit(j).eq.(10000*ie+iturn))then
 5482                                   if (part_impact(j).lt.-0.5d0) then
 5483                                         write(*,*)
 5484      &                                  'ERR> Invalid impact parameter!'
 5485      &                                  , part_impact(j)
 5486                                         write(outlun,*)
 5487      &                                  'ERR> Invalid impact parameter!'
 5488      &                                  , part_impact(j)
 5489                                         stop
 5490                                   endif
 5491                                   n_impact = n_impact + 1
 5492                                   sum = sum + part_impact(j)
 5493                                   sqsum = sqsum + part_impact(j)**2
 5494                                   if (part_hit(j).gt.0 
 5495      &                            .and. dowrite_impact) write(49,*)
 5496      &                            part_impact(j), part_indiv(j)
 5497                                 endif
 5498                         end do
 5499                         if (n_impact.gt.0) then
 5500                                 average = sum/n_impact
 5501                                 if(sqsum/n_impact.ge.average**2) then
 5502                                   sigma=sqrt(sqsum/n_impact- average**2)
 5503                                 else
 5504                                   sigma = 0d0
 5505                                 endif
 5506                         endif
 5507 !++  Some information
 5508                         write(*,*)
 5509      &                  'INFO>  Selected collimator had N hits. N: ',
 5510      &                  num_selhit
 5511                         write(*,*)
 5512      &                  'INFO>  Number of impacts                : ',
 5513      &                  n_impact
 5514                         write(*,*)
 5515      &                  'INFO>  Number of escaped protons        : ',  
 5516      &                  num_surhit
 5517                         write(*,*)                                    
 5518      &                  'INFO>  Average impact parameter [m]     : ',  
 5519      &                  average
 5520                         write(*,*)                                    
 5521      &'                 INFO>  Sigma impact parameter [m]       : ',  
 5522      &                  sigma
 5523 !
 5524                         if (dowrite_impact) close(49)
 5525 !++  End of    S E L E C T E D   collimator
 5526                 endif
 5527 !---------------------------------------------------------
 5528 !++  End of check for known collimator
 5529         endif
 5530 !------------------------------------------------------------------
 5531 !++  Here leave the known collimator IF loop...
 5532 !_______________________________________________________________________
 5533 !++  If it is just a drift...
 5534         else
 5535 !
 5536                 do 23 j=1,napx
 5537                         xv(1,j)=xv(1,j)+stracki*yv(1,j)
 5538                         xv(2,j)=xv(2,j)+stracki*yv(2,j)
 5539                         sigmv(j)=sigmv(j)+stracki*(c1e3-rvv(j)*         &
 5540      &                  (c1e3+(yv(1,j)*yv(1,j)+yv(2,j)*yv(2,j))*c5m4))
 5541                         xj     = (xv(1,j)-torbx(ie))/1d3
 5542                         xpj    = (yv(1,j)-torbxp(ie))/1d3
 5543                         yj     = (xv(2,j)-torby(ie))/1d3
 5544                         ypj    = (yv(2,j)-torbyp(ie))/1d3
 5545                         pj     = ejv(j)/1.e3
 5546                         if(firstrun) then
 5547                                  if (iturn.eq.1.and.j.eq.1) then
 5548                                         sum_ax(ie)=0d0
 5549                                         sum_ay(ie)=0d0
 5550                                  endif
 5551                         endif
 5552                         gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
 5553                         gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
 5554                         if (part_abs(j).eq.0) then
 5555           
 5556                                 xdebug(ie)=xj
 5557                                 xpdebug(ie)=xpj
 5558                                 ydebug(ie)=yj
 5559                                 ypdebug(ie)=ypj
 5560                                 xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*
 5561      &                          tbetax(ie))
 5562                                 xpdebugN(ie)=(xdebug(ie)*talphax(ie)+
 5563      &                          xpdebug(ie)*tbetax(ie))
 5564      &                          /sqrt(myemitx0*tbetax(ie))
 5565                                 ydebugN(ie)=ydebug(ie)/sqrt(myemity0*
 5566      &                          tbetay(ie))
 5567                                 ypdebugN(ie)=(ydebug(ie)*talphay(ie)+
 5568      &                          ypdebug(ie)*tbetay(ie))
 5569      &                          /sqrt(myemity0*tbetay(ie))
 5570           
 5571                                 nspx    = sqrt(                         &
 5572      &                          abs( gammax*(xj)**2 +                   &
 5573      &                          2d0*talphax(ie)*xj*xpj +                &
 5574      &                          tbetax(ie)*xpj**2 )/myemitx0            &
 5575      &                          )
 5576                                 nspy    = sqrt(                         &
 5577      &                          abs( gammay*(yj)**2 +                   &
 5578      &                          2d0*talphay(ie)*yj*ypj +                &
 5579      &                          tbetay(ie)*ypj**2 )/myemity0            
 5580      &                          )
 5581                                 sum_ax(ie)   = sum_ax(ie) + nspx
 5582                                 sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
 5583                                 sum_ay(ie)   = sum_ay(ie) + nspy
 5584                                 sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
 5585                                 nampl(ie)    = nampl(ie) + 1
 5586                         else
 5587                                 nspx = 0d0
 5588                                 nspy = 0d0
 5589                         endif
 5590                                 sampl(ie)    = totals
 5591                                 ename(ie)    = bez(myix)(1:16)
 5592  23             continue
 5593           endif
 5594           goto 650
 5595 !GRD END OF THE CHANGES FOR COLLIMATION STUDIES, BACK TO NORMAL SIXTRACK STUFF
 5596    30     do 40 j=1,napx
 5597             ejf0v(j)=ejfv(j)
 5598             if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
 5599             if(kz(ix).eq.12) then
 5600               ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+               &
 5601      &phasc(ix))
 5602             else
 5603               ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j))
 5604             endif
 5605             ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
 5606             rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
 5607             dpsv(j)=(ejfv(j)-e0f)/e0f
 5608             oidpsv(j)=one/(one+dpsv(j))
 5609             dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
 5610             yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
 5611             yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
 5612  40       continue
 5613           if(n.eq.1) write(98,'(1p,6(2x,e25.18))')                      &
 5614      &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),j=1,napx)
 5615           goto 640
 5616 !--HORIZONTAL DIPOLE
 5617    50     do 60 j=1,napx
 5618             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
 5619             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
 5620    60     continue
 5621           goto 640
 5622 !--NORMAL QUADRUPOLE
 5623    70     do 80 j=1,napx
 5624             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5625      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5626             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5627      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5628             crkve=xlv(j)
 5629             cikve=zlv(j)
 5630             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5631      &stracks(i)*cikve)
 5632             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5633      &stracks(i)*crkve)
 5634    80     continue
 5635           goto 640
 5636 !--NORMAL SEXTUPOLE
 5637    90     do 100 j=1,napx
 5638             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5639      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5640             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5641      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5642             crkve=xlv(j)
 5643             cikve=zlv(j)
 5644            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5645            cikve=crkve*zlv(j)+cikve*xlv(j)
 5646            crkve=crkveuk
 5647             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5648      &stracks(i)*cikve)
 5649             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5650      &stracks(i)*crkve)
 5651   100     continue
 5652           goto 640
 5653 !--NORMAL OCTUPOLE
 5654   110     do 120 j=1,napx
 5655             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5656      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5657             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5658      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5659             crkve=xlv(j)
 5660             cikve=zlv(j)
 5661            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5662            cikve=crkve*zlv(j)+cikve*xlv(j)
 5663            crkve=crkveuk
 5664            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5665            cikve=crkve*zlv(j)+cikve*xlv(j)
 5666            crkve=crkveuk
 5667             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5668      &stracks(i)*cikve)
 5669             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5670      &stracks(i)*crkve)
 5671   120     continue
 5672           goto 640
 5673 !--NORMAL DECAPOLE
 5674   130     do 140 j=1,napx
 5675             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5676      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5677             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5678      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5679             crkve=xlv(j)
 5680             cikve=zlv(j)
 5681            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5682            cikve=crkve*zlv(j)+cikve*xlv(j)
 5683            crkve=crkveuk
 5684            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5685            cikve=crkve*zlv(j)+cikve*xlv(j)
 5686            crkve=crkveuk
 5687            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5688            cikve=crkve*zlv(j)+cikve*xlv(j)
 5689            crkve=crkveuk
 5690             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5691      &stracks(i)*cikve)
 5692             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5693      &stracks(i)*crkve)
 5694   140     continue
 5695           goto 640
 5696 !--NORMAL DODECAPOLE
 5697   150     do 160 j=1,napx
 5698             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5699      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5700             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5701      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5702             crkve=xlv(j)
 5703             cikve=zlv(j)
 5704            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5705            cikve=crkve*zlv(j)+cikve*xlv(j)
 5706            crkve=crkveuk
 5707            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5708            cikve=crkve*zlv(j)+cikve*xlv(j)
 5709            crkve=crkveuk
 5710            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5711            cikve=crkve*zlv(j)+cikve*xlv(j)
 5712            crkve=crkveuk
 5713            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5714            cikve=crkve*zlv(j)+cikve*xlv(j)
 5715            crkve=crkveuk
 5716             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5717      &stracks(i)*cikve)
 5718             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5719      &stracks(i)*crkve)
 5720   160     continue
 5721           goto 640
 5722 !--NORMAL 14-POLE
 5723   170     do 180 j=1,napx
 5724             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5725      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5726             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5727      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5728             crkve=xlv(j)
 5729             cikve=zlv(j)
 5730            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5731            cikve=crkve*zlv(j)+cikve*xlv(j)
 5732            crkve=crkveuk
 5733            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5734            cikve=crkve*zlv(j)+cikve*xlv(j)
 5735            crkve=crkveuk
 5736            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5737            cikve=crkve*zlv(j)+cikve*xlv(j)
 5738            crkve=crkveuk
 5739            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5740            cikve=crkve*zlv(j)+cikve*xlv(j)
 5741            crkve=crkveuk
 5742            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5743            cikve=crkve*zlv(j)+cikve*xlv(j)
 5744            crkve=crkveuk
 5745             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5746      &stracks(i)*cikve)
 5747             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5748      &stracks(i)*crkve)
 5749   180     continue
 5750           goto 640
 5751 !--NORMAL 16-POLE
 5752   190     do 200 j=1,napx
 5753             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5754      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5755             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5756      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5757             crkve=xlv(j)
 5758             cikve=zlv(j)
 5759            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5760            cikve=crkve*zlv(j)+cikve*xlv(j)
 5761            crkve=crkveuk
 5762            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5763            cikve=crkve*zlv(j)+cikve*xlv(j)
 5764            crkve=crkveuk
 5765            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5766            cikve=crkve*zlv(j)+cikve*xlv(j)
 5767            crkve=crkveuk
 5768            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5769            cikve=crkve*zlv(j)+cikve*xlv(j)
 5770            crkve=crkveuk
 5771            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5772            cikve=crkve*zlv(j)+cikve*xlv(j)
 5773            crkve=crkveuk
 5774            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5775            cikve=crkve*zlv(j)+cikve*xlv(j)
 5776            crkve=crkveuk
 5777             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5778      &stracks(i)*cikve)
 5779             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5780      &stracks(i)*crkve)
 5781   200     continue
 5782           goto 640
 5783 !--NORMAL 18-POLE
 5784   210     do 220 j=1,napx
 5785             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5786      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5787             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5788      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5789             crkve=xlv(j)
 5790             cikve=zlv(j)
 5791            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5792            cikve=crkve*zlv(j)+cikve*xlv(j)
 5793            crkve=crkveuk
 5794            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5795            cikve=crkve*zlv(j)+cikve*xlv(j)
 5796            crkve=crkveuk
 5797            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5798            cikve=crkve*zlv(j)+cikve*xlv(j)
 5799            crkve=crkveuk
 5800            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5801            cikve=crkve*zlv(j)+cikve*xlv(j)
 5802            crkve=crkveuk
 5803            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5804            cikve=crkve*zlv(j)+cikve*xlv(j)
 5805            crkve=crkveuk
 5806            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5807            cikve=crkve*zlv(j)+cikve*xlv(j)
 5808            crkve=crkveuk
 5809            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5810            cikve=crkve*zlv(j)+cikve*xlv(j)
 5811            crkve=crkveuk
 5812             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5813      &stracks(i)*cikve)
 5814             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5815      &stracks(i)*crkve)
 5816   220     continue
 5817           goto 640
 5818 !--NORMAL 20-POLE
 5819   230     do 240 j=1,napx
 5820             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 5821      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5822             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 5823      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5824             crkve=xlv(j)
 5825             cikve=zlv(j)
 5826            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5827            cikve=crkve*zlv(j)+cikve*xlv(j)
 5828            crkve=crkveuk
 5829            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5830            cikve=crkve*zlv(j)+cikve*xlv(j)
 5831            crkve=crkveuk
 5832            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5833            cikve=crkve*zlv(j)+cikve*xlv(j)
 5834            crkve=crkveuk
 5835            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5836            cikve=crkve*zlv(j)+cikve*xlv(j)
 5837            crkve=crkveuk
 5838            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5839            cikve=crkve*zlv(j)+cikve*xlv(j)
 5840            crkve=crkveuk
 5841            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5842            cikve=crkve*zlv(j)+cikve*xlv(j)
 5843            crkve=crkveuk
 5844            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5845            cikve=crkve*zlv(j)+cikve*xlv(j)
 5846            crkve=crkveuk
 5847            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 5848            cikve=crkve*zlv(j)+cikve*xlv(j)
 5849            crkve=crkveuk
 5850             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 5851      &stracks(i)*cikve)
 5852             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 5853      &stracks(i)*crkve)
 5854   240     continue
 5855           goto 640
 5856   250     continue
 5857           do 260 j=1,napx
 5858             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5859      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5860             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5861      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5862             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 5863      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 5864      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 5865             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 5866      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 5867      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 5868             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 5869   260     continue
 5870           goto 640
 5871   270     continue
 5872           do 280 j=1,napx
 5873             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5874      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5875             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5876      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5877             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 5878      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 5879      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 5880             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 5881      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 5882      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 5883             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 5884   280     continue
 5885           goto 410
 5886   290     continue
 5887           do 300 j=1,napx
 5888             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5889      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5890             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5891      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5892             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 5893      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 5894             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 5895      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 5896             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 5897   300     continue
 5898           goto 640
 5899   310     continue
 5900           do 320 j=1,napx
 5901             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5902      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5903             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5904      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5905             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 5906      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 5907             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 5908      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 5909             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 5910   320     continue
 5911           goto 410
 5912   330     continue
 5913           do 340 j=1,napx
 5914             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5915      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5916             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5917      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5918             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 5919      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 5920      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 5921             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 5922      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 5923      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 5924             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 5925   340     continue
 5926           goto 640
 5927   350     continue
 5928           do 360 j=1,napx
 5929             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5930      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5931             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5932      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5933             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 5934      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 5935      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 5936             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 5937      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 5938      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 5939             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 5940   360     continue
 5941           goto 410
 5942   370     continue
 5943           do 380 j=1,napx
 5944             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5945      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5946             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5947      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5948             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 5949      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 5950             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 5951      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 5952             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 5953   380     continue
 5954           goto 640
 5955   390     continue
 5956           do 400 j=1,napx
 5957             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5958      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5959             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5960      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5961             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 5962      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 5963             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 5964      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 5965             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 5966   400     continue
 5967   410     r0=ek(ix)
 5968           nmz=nmu(ix)
 5969           if(nmz.ge.2) then
 5970             do 430 j=1,napx
 5971             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 5972      &(xv(2,j)-zsiv(1,i))*tilts(i)
 5973             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 5974      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 5975               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
 5976               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
 5977               crkve=xlvj
 5978               cikve=zlvj
 5979                 do 420 k=3,nmz
 5980                   crkveuk=crkve*xlvj-cikve*zlvj
 5981                   cikve=crkve*zlvj+cikve*xlvj
 5982                   crkve=crkveuk
 5983                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
 5984                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
 5985   420           continue
 5986               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
 5987               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
 5988   430       continue
 5989           else
 5990             do 435 j=1,napx
 5991               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
 5992      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
 5993               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
 5994      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
 5995   435       continue
 5996           endif
 5997           goto 640
 5998 !--SKEW ELEMENTS
 5999 !--VERTICAL DIPOLE
 6000   440     do 450 j=1,napx
 6001             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
 6002             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
 6003   450     continue
 6004           goto 640
 6005 !--SKEW QUADRUPOLE
 6006   460     do 470 j=1,napx
 6007             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6008      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6009             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6010      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6011             crkve=xlv(j)
 6012             cikve=zlv(j)
 6013             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6014      &stracks(i)*crkve)
 6015             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6016      &stracks(i)*cikve)
 6017   470     continue
 6018           goto 640
 6019 !--SKEW SEXTUPOLE
 6020   480     do 490 j=1,napx
 6021             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6022      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6023             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6024      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6025             crkve=xlv(j)
 6026             cikve=zlv(j)
 6027            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6028            cikve=crkve*zlv(j)+cikve*xlv(j)
 6029            crkve=crkveuk
 6030             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6031      &stracks(i)*crkve)
 6032             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6033      &stracks(i)*cikve)
 6034   490     continue
 6035           goto 640
 6036 !--SKEW OCTUPOLE
 6037   500     do 510 j=1,napx
 6038             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6039      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6040             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6041      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6042             crkve=xlv(j)
 6043             cikve=zlv(j)
 6044            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6045            cikve=crkve*zlv(j)+cikve*xlv(j)
 6046            crkve=crkveuk
 6047            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6048            cikve=crkve*zlv(j)+cikve*xlv(j)
 6049            crkve=crkveuk
 6050             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6051      &stracks(i)*crkve)
 6052             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6053      &stracks(i)*cikve)
 6054   510     continue
 6055           goto 640
 6056 !--SKEW DECAPOLE
 6057   520     do 530 j=1,napx
 6058             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6059      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6060             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6061      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6062             crkve=xlv(j)
 6063             cikve=zlv(j)
 6064            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6065            cikve=crkve*zlv(j)+cikve*xlv(j)
 6066            crkve=crkveuk
 6067            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6068            cikve=crkve*zlv(j)+cikve*xlv(j)
 6069            crkve=crkveuk
 6070            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6071            cikve=crkve*zlv(j)+cikve*xlv(j)
 6072            crkve=crkveuk
 6073             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6074      &stracks(i)*crkve)
 6075             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6076      &stracks(i)*cikve)
 6077   530     continue
 6078           goto 640
 6079 !--SKEW DODECAPOLE
 6080   540     do 550 j=1,napx
 6081             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6082      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6083             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6084      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6085             crkve=xlv(j)
 6086             cikve=zlv(j)
 6087            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6088            cikve=crkve*zlv(j)+cikve*xlv(j)
 6089            crkve=crkveuk
 6090            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6091            cikve=crkve*zlv(j)+cikve*xlv(j)
 6092            crkve=crkveuk
 6093            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6094            cikve=crkve*zlv(j)+cikve*xlv(j)
 6095            crkve=crkveuk
 6096            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6097            cikve=crkve*zlv(j)+cikve*xlv(j)
 6098            crkve=crkveuk
 6099             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6100      &stracks(i)*crkve)
 6101             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6102      &stracks(i)*cikve)
 6103   550     continue
 6104           goto 640
 6105 !--SKEW 14-POLE
 6106   560     do 570 j=1,napx
 6107             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6108      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6109             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6110      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6111             crkve=xlv(j)
 6112             cikve=zlv(j)
 6113            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6114            cikve=crkve*zlv(j)+cikve*xlv(j)
 6115            crkve=crkveuk
 6116            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6117            cikve=crkve*zlv(j)+cikve*xlv(j)
 6118            crkve=crkveuk
 6119            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6120            cikve=crkve*zlv(j)+cikve*xlv(j)
 6121            crkve=crkveuk
 6122            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6123            cikve=crkve*zlv(j)+cikve*xlv(j)
 6124            crkve=crkveuk
 6125            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6126            cikve=crkve*zlv(j)+cikve*xlv(j)
 6127            crkve=crkveuk
 6128             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6129      &stracks(i)*crkve)
 6130             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6131      &stracks(i)*cikve)
 6132   570     continue
 6133           goto 640
 6134 !--SKEW 16-POLE
 6135   580     do 590 j=1,napx
 6136             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6137      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6138             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6139      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6140             crkve=xlv(j)
 6141             cikve=zlv(j)
 6142            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6143            cikve=crkve*zlv(j)+cikve*xlv(j)
 6144            crkve=crkveuk
 6145            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6146            cikve=crkve*zlv(j)+cikve*xlv(j)
 6147            crkve=crkveuk
 6148            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6149            cikve=crkve*zlv(j)+cikve*xlv(j)
 6150            crkve=crkveuk
 6151            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6152            cikve=crkve*zlv(j)+cikve*xlv(j)
 6153            crkve=crkveuk
 6154            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6155            cikve=crkve*zlv(j)+cikve*xlv(j)
 6156            crkve=crkveuk
 6157            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6158            cikve=crkve*zlv(j)+cikve*xlv(j)
 6159            crkve=crkveuk
 6160             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6161      &stracks(i)*crkve)
 6162             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6163      &stracks(i)*cikve)
 6164   590     continue
 6165           goto 640
 6166 !--SKEW 18-POLE
 6167   600     do 610 j=1,napx
 6168             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6169      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6170             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6171      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6172             crkve=xlv(j)
 6173             cikve=zlv(j)
 6174            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6175            cikve=crkve*zlv(j)+cikve*xlv(j)
 6176            crkve=crkveuk
 6177            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6178            cikve=crkve*zlv(j)+cikve*xlv(j)
 6179            crkve=crkveuk
 6180            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6181            cikve=crkve*zlv(j)+cikve*xlv(j)
 6182            crkve=crkveuk
 6183            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6184            cikve=crkve*zlv(j)+cikve*xlv(j)
 6185            crkve=crkveuk
 6186            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6187            cikve=crkve*zlv(j)+cikve*xlv(j)
 6188            crkve=crkveuk
 6189            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6190            cikve=crkve*zlv(j)+cikve*xlv(j)
 6191            crkve=crkveuk
 6192            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6193            cikve=crkve*zlv(j)+cikve*xlv(j)
 6194            crkve=crkveuk
 6195             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6196      &stracks(i)*crkve)
 6197             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6198      &stracks(i)*cikve)
 6199   610     continue
 6200           goto 640
 6201 !--SKEW 20-POLE
 6202   620     do 630 j=1,napx
 6203             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 6204      &(xv(2,j)-zsiv(1,i))*tilts(i)
 6205             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 6206      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 6207             crkve=xlv(j)
 6208             cikve=zlv(j)
 6209            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6210            cikve=crkve*zlv(j)+cikve*xlv(j)
 6211            crkve=crkveuk
 6212            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6213            cikve=crkve*zlv(j)+cikve*xlv(j)
 6214            crkve=crkveuk
 6215            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6216            cikve=crkve*zlv(j)+cikve*xlv(j)
 6217            crkve=crkveuk
 6218            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6219            cikve=crkve*zlv(j)+cikve*xlv(j)
 6220            crkve=crkveuk
 6221            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6222            cikve=crkve*zlv(j)+cikve*xlv(j)
 6223            crkve=crkveuk
 6224            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6225            cikve=crkve*zlv(j)+cikve*xlv(j)
 6226            crkve=crkveuk
 6227            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6228            cikve=crkve*zlv(j)+cikve*xlv(j)
 6229            crkve=crkveuk
 6230            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 6231            cikve=crkve*zlv(j)+cikve*xlv(j)
 6232            crkve=crkveuk
 6233             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 6234      &stracks(i)*crkve)
 6235             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 6236      &stracks(i)*cikve)
 6237   630     continue
 6238           goto 640
 6239   680     continue
 6240           do 690 j=1,napx
 6241               if(ibbc.eq.0) then
 6242                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 6243                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 6244               else
 6245                 crkveb(j)=                                              &
 6246      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 6247      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 6248                 cikveb(j)=                                              &
 6249      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 6250      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 6251               endif
 6252             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
 6253             if(rho2b(j).le.pieni)                                       &
 6254      &goto 690
 6255             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
 6256             if(ibbc.eq.0) then
 6257               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
 6258      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
 6259               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
 6260      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
 6261             else
 6262               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 6263      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
 6264      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 6265      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 6266               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 6267               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 6268      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
 6269      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 6270      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 6271               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 6272             endif
 6273   690     continue
 6274           goto 640
 6275   700     continue
 6276           if(ibtyp.eq.0) then
 6277             do j=1,napx
 6278               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 6279               rb(j)=sqrt(r2b(j))
 6280               rkb(j)=strack(i)*pisqrt/rb(j)
 6281               if(ibbc.eq.0) then
 6282                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 6283                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 6284               else
 6285                 crkveb(j)=                                              &
 6286      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 6287      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 6288                 cikveb(j)=                                              &
 6289      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 6290      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 6291               endif
 6292               xrb(j)=abs(crkveb(j))/rb(j)
 6293               zrb(j)=abs(cikveb(j))/rb(j)
 6294               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
 6295               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 6296      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 6297               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 6298               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 6299               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
 6300               if(ibbc.eq.0) then
 6301                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 6302      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 6303                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 6304      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 6305               else
 6306                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6307      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6308      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6309      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 6310                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 6311                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6312      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6313      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6314      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 6315                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 6316               endif
 6317             enddo
 6318           else if(ibtyp.eq.1) then
 6319             do j=1,napx
 6320               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 6321               rb(j)=sqrt(r2b(j))
 6322               rkb(j)=strack(i)*pisqrt/rb(j)
 6323               if(ibbc.eq.0) then
 6324                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 6325                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 6326               else
 6327                 crkveb(j)=                                              &
 6328      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 6329      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 6330                 cikveb(j)=                                              &
 6331      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 6332      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 6333               endif
 6334               xrb(j)=abs(crkveb(j))/rb(j)
 6335               zrb(j)=abs(cikveb(j))/rb(j)
 6336               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 6337      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 6338               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 6339               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 6340             enddo
 6341             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
 6342             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
 6343             do j=1,napx
 6344               if(ibbc.eq.0) then
 6345                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 6346      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 6347                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 6348      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 6349               else
 6350                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6351      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6352      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6353      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 6354                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 6355                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6356      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6357      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6358      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 6359                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 6360               endif
 6361             enddo
 6362           endif
 6363           goto 640
 6364   720     continue
 6365           if(ibtyp.eq.0) then
 6366             do j=1,napx
 6367               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 6368               rb(j)=sqrt(r2b(j))
 6369               rkb(j)=strack(i)*pisqrt/rb(j)
 6370               if(ibbc.eq.0) then
 6371                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 6372                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 6373               else
 6374                 crkveb(j)=                                              &
 6375      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 6376      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 6377                 cikveb(j)=                                              &
 6378      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 6379      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 6380               endif
 6381               xrb(j)=abs(crkveb(j))/rb(j)
 6382               zrb(j)=abs(cikveb(j))/rb(j)
 6383               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
 6384               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 6385      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 6386               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 6387               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 6388               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
 6389               if(ibbc.eq.0) then
 6390                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 6391      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 6392                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 6393      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 6394               else
 6395                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6396      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6397      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6398      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 6399                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 6400                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6401      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6402      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6403      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 6404                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 6405               endif
 6406             enddo
 6407           else if(ibtyp.eq.1) then
 6408             do j=1,napx
 6409               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 6410               rb(j)=sqrt(r2b(j))
 6411               rkb(j)=strack(i)*pisqrt/rb(j)
 6412               if(ibbc.eq.0) then
 6413                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 6414                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 6415               else
 6416                 crkveb(j)=                                              &
 6417      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 6418      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 6419                 cikveb(j)=                                              &
 6420      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 6421      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 6422               endif
 6423               xrb(j)=abs(crkveb(j))/rb(j)
 6424               zrb(j)=abs(cikveb(j))/rb(j)
 6425               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 6426      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 6427               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 6428               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 6429             enddo
 6430             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
 6431             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
 6432             do j=1,napx
 6433               if(ibbc.eq.0) then
 6434                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 6435      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 6436                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 6437      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 6438               else
 6439                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6440      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6441      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6442      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 6443                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 6444                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 6445      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 6446      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 6447      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 6448                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 6449               endif
 6450             enddo
 6451           endif
 6452           goto 640
 6453   730     continue
 6454 !--Hirata's 6D beam-beam kick
 6455             do j=1,napx
 6456               track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
 6457               track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
 6458               track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
 6459               track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
 6460               track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
 6461               track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
 6462             enddo
 6463             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
 6464      &ibbc)
 6465             do j=1,napx
 6466               xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))-             &
 6467      &beamoff(1,imbb(i))
 6468               xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))-             &
 6469      &beamoff(2,imbb(i))
 6470               dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
 6471               oidpsv(j)=one/(one+dpsv(j))
 6472               yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))-            &
 6473      &beamoff(4,imbb(i)))*oidpsv(j)
 6474               yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))-            &
 6475      &beamoff(5,imbb(i)))*oidpsv(j)
 6476               ejfv(j)=dpsv(j)*e0f+e0f
 6477               ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
 6478               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
 6479               if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
 6480             enddo
 6481           goto 640
 6482   740     continue
 6483           irrtr=imtr(ix)
 6484           do j=1,napx
 6485             sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+    &
 6486      &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+                  &
 6487      &rrtr(irrtr,5,4)*yv(2,j)
 6488             pux=xv(1,j)
 6489             dpsv3(j)=dpsv(j)*c1e3
 6490             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
 6491      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
 6492             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
 6493      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
 6494             pux=xv(2,j)
 6495             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
 6496      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
 6497             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
 6498      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
 6499           enddo
 6500  
 6501 !----------------------------------------------------------------------
 6502  
 6503 ! Wire.
 6504  
 6505           goto 640
 6506   745     continue
 6507           xory=1
 6508           nfree=nturn1(ix)
 6509          if(n.gt.nfree) then
 6510           nac=n-nfree
 6511           pi=4d0*atan(1d0)
 6512 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 6513 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 6514           acdipamp=ed(ix)*clight*1.0d-3
 6515 !---------Qd input in tune units
 6516           qd=ek(ix)
 6517 !---------ACphase input in radians
 6518           acphase=acdipph(ix)
 6519           nramp1=nturn2(ix)
 6520           nplato=nturn3(ix)
 6521           nramp2=nturn4(ix)
 6522           do j=1,napx
 6523       if (xory.eq.1) then
 6524         acdipamp2=acdipamp*tilts(i)
 6525         acdipamp1=acdipamp*tiltc(i)
 6526       else
 6527         acdipamp2=acdipamp*tiltc(i)
 6528         acdipamp1=-acdipamp*tilts(i)
 6529       endif
 6530               if(nramp1.gt.nac) then
 6531                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 6532      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 6533                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 6534      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 6535               endif
 6536               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 6537                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 6538      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 6539                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 6540      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 6541               endif
 6542               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 6543      &nac)then
 6544               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 6545      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 6546               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 6547      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 6548               endif
 6549       enddo
 6550       endif
 6551           goto 640
 6552   746     continue
 6553           xory=2
 6554           nfree=nturn1(ix)
 6555          if(n.gt.nfree) then
 6556           nac=n-nfree
 6557           pi=4d0*atan(1d0)
 6558 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 6559 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 6560           acdipamp=ed(ix)*clight*1.0d-3
 6561 !---------Qd input in tune units
 6562           qd=ek(ix)
 6563 !---------ACphase input in radians
 6564           acphase=acdipph(ix)
 6565           nramp1=nturn2(ix)
 6566           nplato=nturn3(ix)
 6567           nramp2=nturn4(ix)
 6568           do j=1,napx
 6569       if (xory.eq.1) then
 6570         acdipamp2=acdipamp*tilts(i)
 6571         acdipamp1=acdipamp*tiltc(i)
 6572       else
 6573         acdipamp2=acdipamp*tiltc(i)
 6574         acdipamp1=-acdipamp*tilts(i)
 6575       endif
 6576               if(nramp1.gt.nac) then
 6577                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 6578      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 6579                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 6580      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 6581               endif
 6582               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 6583                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 6584      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 6585                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 6586      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 6587               endif
 6588               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 6589      &nac)then
 6590               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 6591      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 6592               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 6593      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 6594               endif
 6595       enddo
 6596       endif
 6597           goto 640
 6598  
 6599 !----------------------------
 6600  
 6601 ! Wire.
 6602  
 6603   748     continue
 6604 !     magnetic rigidity
 6605       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
 6606  
 6607       ix = ixcav
 6608       tx = xrms(ix)
 6609       ty = zrms(ix)
 6610       dx = xpl(ix)
 6611       dy = zpl(ix)
 6612       embl = ek(ix)
 6613       l = wirel(ix)
 6614       cur = ed(ix)
 6615  
 6616       leff = embl/cos(tx)/cos(ty)
 6617       rx = dx *cos(tx)-embl*sin(tx)/2
 6618       lin= dx *sin(tx)+embl*cos(tx)/2
 6619       ry = dy *cos(ty)-lin *sin(ty)
 6620       lin= lin*cos(ty)+dy  *sin(ty)
 6621  
 6622       do 750 j=1, napx
 6623  
 6624       xv(1,j) = xv(1,j) * c1m3
 6625       xv(2,j) = xv(2,j) * c1m3
 6626       yv(1,j) = yv(1,j) * c1m3
 6627       yv(2,j) = yv(2,j) * c1m3
 6628  
 6629  
 6630  
 6631       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 6632      &yv(2,j)**2)
 6633       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 6634      &yv(2,j)**2)
 6635  
 6636  
 6637       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
 6638      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 6639      &yv(2,j)**2))-tx)
 6640       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
 6641      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
 6642       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 6643      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
 6644  
 6645       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
 6646      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 6647      &yv(2,j)**2))-ty)
 6648       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
 6649      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
 6650       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 6651      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
 6652  
 6653       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 6654      &yv(2,j)**2)
 6655       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 6656      &yv(2,j)**2)
 6657  
 6658       xi = xv(1,j)-rx
 6659       yi = xv(2,j)-ry
 6660       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
 6661      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 6662      &xi**2+yi**2))
 6663 !GRD FOR CONSISTENSY
 6664       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
 6665      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 6666      &xi**2+yi**2))
 6667  
 6668       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
 6669      &yv(1,j)**2-yv(2,j)**2)
 6670       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
 6671      &yv(1,j)**2-yv(2,j)**2)
 6672  
 6673       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
 6674      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 6675      &yv(2,j)**2))+ty)
 6676       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
 6677      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
 6678       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 6679      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
 6680  
 6681       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
 6682      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 6683      &yv(2,j)**2))+tx)
 6684       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
 6685      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
 6686       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 6687      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
 6688  
 6689  
 6690       xv(1,j) = xv(1,j) + embl*tan(tx)
 6691       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
 6692  
 6693       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 6694      &yv(2,j)**2)
 6695       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 6696      &yv(2,j)**2)
 6697  
 6698       xv(1,j) = xv(1,j) * c1e3
 6699       xv(2,j) = xv(2,j) * c1e3
 6700       yv(1,j) = yv(1,j) * c1e3
 6701       yv(2,j) = yv(2,j) * c1e3
 6702  
 6703 !-----------------------------------------------------------------------
 6704  
 6705   750     continue
 6706           goto 640
 6707  
 6708 !----------------------------
 6709  
 6710   640     continue
 6711 !GRD
 6712 !GRD UPGRADE JANUARY 2005
 6713 !GRD
 6714       if (firstrun) then
 6715         if (rselect.gt.0 .and. rselect.lt.65) then
 6716           do j = 1, napx
 6717 !
 6718             xj     = (xv(1,j)-torbx(ie))/1d3
 6719             xpj    = (yv(1,j)-torbxp(ie))/1d3
 6720             yj     = (xv(2,j)-torby(ie))/1d3
 6721             ypj    = (yv(2,j)-torbyp(ie))/1d3
 6722             pj     = ejv(j)/1d3
 6723 !GRD
 6724             if (iturn.eq.1.and.j.eq.1) then
 6725               sum_ax(ie)=0d0
 6726               sum_ay(ie)=0d0
 6727             endif
 6728 !GRD
 6729 !
 6730             if (tbetax(ie).gt.0.) then
 6731               gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
 6732               gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
 6733             else
 6734               gammax = (1d0 + talphax(ie-1)**2)/tbetax(ie-1)
 6735               gammay = (1d0 + talphay(ie-1)**2)/tbetay(ie-1)
 6736             endif
 6737 !
 6738             if (part_abs(j).eq.0) then
 6739               if(tbetax(ie).gt.0.) then
 6740                 nspx    = sqrt(                                         &
 6741      &               abs( gammax*(xj)**2 +                              &
 6742      &               2d0*talphax(ie)*xj*xpj +                           &
 6743      &               tbetax(ie)*xpj**2 )/myemitx0                       &
 6744      &               )
 6745                 nspy    = sqrt(                                         &
 6746      &               abs( gammay*(yj)**2 +                              &
 6747      &               2d0*talphay(ie)*yj*ypj +                           &
 6748      &               tbetay(ie)*ypj**2 )/myemity0                       &
 6749      &               )
 6750               else
 6751                 nspx    = sqrt(                                         &
 6752      &               abs( gammax*(xj)**2 +                              &
 6753      &               2d0*talphax(ie-1)*xj*xpj +                         &
 6754      &               tbetax(ie-1)*xpj**2 )/myemitx0                     &
 6755      &               )
 6756                 nspy    = sqrt(                                         &
 6757      &               abs( gammay*(yj)**2 +                              &
 6758      &               2d0*talphay(ie-1)*yj*ypj +                         &
 6759      &               tbetay(ie-1)*ypj**2 )/myemity0                     &
 6760      &               )
 6761               endif
 6762           
 6763           xdebug(ie)=xj
 6764           xpdebug(ie)=xpj
 6765           ydebug(ie)=yj
 6766           ypdebug(ie)=ypj
 6767           xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*tbetax(ie))
 6768           xpdebugN(ie)=(xdebug(ie)*talphax(ie)+xpdebug(ie)*tbetax(ie))
 6769      &    /sqrt(myemitx0*tbetax(ie))
 6770           ydebugN(ie)=ydebug(ie)/sqrt(myemity0*tbetay(ie))
 6771           ypdebugN(ie)=(ydebug(ie)*talphay(ie)+ypdebug(ie)*tbetay(ie))
 6772      &    /sqrt(myemity0*tbetay(ie))
 6773           
 6774 !
 6775               sum_ax(ie)   = sum_ax(ie) + nspx
 6776               sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
 6777               sum_ay(ie)   = sum_ay(ie) + nspy
 6778               sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
 6779               nampl(ie)    = nampl(ie) + 1
 6780             else
 6781               nspx = 0d0
 6782               nspy = 0d0
 6783             endif
 6784               sampl(ie)    = totals
 6785               ename(ie)    = bez(myix)(1:16)
 6786           end do
 6787         endif
 6788       endif
 6789 !GRD
 6790 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!
 6791 !GRD
 6792           if (dowritetracks) then
 6793             do j = 1, napx
 6794               xj     = (xv(1,j)-torbx(ie))/1d3
 6795               xpj    = (yv(1,j)-torbxp(ie))/1d3
 6796               yj     = (xv(2,j)-torby(ie))/1d3
 6797               ypj    = (yv(2,j)-torbyp(ie))/1d3
 6798 !
 6799               arcdx = 2.5d0
 6800               arcbetax = 180d0
 6801 !
 6802                 if (xj.le.0.) then
 6803                   xdisp = xj + (pj-myenom)/myenom * arcdx               &
 6804      &* sqrt(tbetax(ie)/arcbetax)
 6805                 else
 6806                   xdisp = xj - (pj-myenom)/myenom * arcdx               &
 6807      &* sqrt(tbetax(ie)/arcbetax)
 6808                 endif
 6809                 xndisp = xj
 6810                 nspxd   = sqrt(                                         &
 6811      &abs(gammax*xdisp**2 + 2d0*talphax(ie)*xdisp*xpj                   &
 6812      &+ tbetax(ie)*xpj**2)/myemitx0                                     &
 6813      &)
 6814                 nspx    = sqrt(                                         &
 6815      &abs( gammax*xndisp**2 + 2d0*talphax(ie)*xndisp*                   &
 6816      &xpj + tbetax(ie)*xpj**2 )/myemitx0                                &
 6817      &)
 6818                 nspy    = sqrt(                                         &
 6819      &abs( gammay*yj**2 + 2d0*talphay(ie)*yj                            &
 6820      &*ypj + tbetay(ie)*ypj**2 )/myemity0                               &
 6821      &)
 6822 !
 6823 !
 6824 !
 6825          if(part_abs(j).eq.0) then
 6826          if ((secondary(j).eq.1.or.tertiary(j).eq.2.or.other(j).eq.4)   &
 6827      & .and.(xv(1,j).lt.99d0 .and. xv(2,j).lt.99d0) .and.               &
 6828 !GRD
 6829 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
 6830 !GRD                                                                    &
 6831      &(                                                                 &
 6832      &((                                                                &
 6833      &(xv(1,j)*1d-3)**2                                                 &
 6834      &/                                                                 &
 6835      &(tbetax(ie)*myemitx0)                                             &
 6836  !    &).ge.sigsecut2).and.                                              &
 6837      &).ge.dble(sigsecut2)).or.                                         &
 6838      &((                                                                &
 6839      &(xv(2,j)*1d-3)**2                                                 &
 6840      &/                                                                 &
 6841      &(tbetay(ie)*myemity0)                                             &
 6842      &).ge.dble(sigsecut2)).or.                                         &
 6843      &(((xv(1,j)*1d-3)**2/(tbetax(ie)*myemitx0))+                       &
 6844      &((xv(2,j)*1d-3)**2/(tbetay(ie)*myemity0))                         &
 6845      &.ge.sigsecut3)                                                    &
 6846      &) ) then
 6847                 xj     = (xv(1,j)-torbx(ie))/1d3
 6848                 xpj    = (yv(1,j)-torbxp(ie))/1d3
 6849                 yj     = (xv(2,j)-torby(ie))/1d3
 6850                 ypj    = (yv(2,j)-torbyp(ie))/1d3
 6851           write(38,'(1x,i8,1x,i4,1x,f8.2,5(1x,e11.3),1x,i4)')           &
 6852      &ipart(j)+100*samplenumber,iturn,sampl(ie),                        &
 6853      &xv(1,j),yv(1,j),                                                  &
 6854      &xv(2,j),yv(2,j),(ejv(j)-myenom)/myenom,                           &
 6855      &secondary(j)+tertiary(j)+other(j)
 6856               endif
 6857          endif
 6858             end do
 6859 !!GRD+KAD here we dump the location within RHIC where any one transvere
 6860 !!GRD+KAD dimension of the beam gets bigger than 4 cm => kind of like a
 6861 !!GRD+KAD raw aperture check to obtain loss maps...
 6862 !!GRD+KAD then we just delete the particle from the tracking, so as not to have
 6863 !!GRD+KAD strange values for the impact parameter and have losses at other crazy
 6864 !!GRD+KAD locations
 6865 !!AUGUST2005 comment that out for LHC studies
 6866 !!JUNE2005 here I close the "if(dowritetracks)" outside of the firstrun flag
 6867       endif
 6868 !GRD END OF UPGRADE
 6869           kpz=abs(kp(ix))
 6870           if(kpz.eq.0) goto 650
 6871           if(kpz.eq.1) goto 650
 6872   650   continue
 6873 !GRD
 6874 !UPGRADE JANUARY 2005
 6875 !__________________________________________________________________
 6876 !++  Now do analysis at selected elements...
 6877 !
 6878 !++  Save twiss functions of present element
 6879 !
 6880         ax0  = talphax(ie)
 6881         bx0  = tbetax(ie)
 6882         mux0 = mux(ie)
 6883         ay0  = talphay(ie)
 6884         by0  = tbetay(ie)
 6885         muy0 = muy(ie)
 6886 !GRD GET THE COORDINATES OF THE PARTICLES AT THE IEth ELEMENT:
 6887         do j = 1,napx
 6888               xgrd(j)  = xv(1,j)
 6889               xpgrd(j) = yv(1,j)
 6890               ygrd(j)  = xv(2,j)
 6891               ypgrd(j) = yv(2,j)
 6892 !
 6893               xineff(j)  = xv(1,j)                                      &
 6894      &        - torbx(ie)
 6895               xpineff(j) = yv(1,j)                                      &
 6896      &        - torbxp(ie)
 6897               yineff(j)  = xv(2,j)                                      &
 6898      &        - torby(ie)
 6899               ypineff(j) = yv(2,j)                                      &
 6900      &        - torbyp(ie)
 6901 !
 6902               pgrd(j)  = ejv(j)
 6903               ejfvgrd(j) = ejfv(j)
 6904               sigmvgrd(j) = sigmv(j)
 6905               rvvgrd(j) = rvv(j)
 6906               dpsvgrd(j) = dpsv(j)
 6907               oidpsvgrd(j) = oidpsv(j)
 6908               dpsv1grd(j) = dpsv1(j)
 6909 !GRD IMPORTANT: ALL PARTICLES ABSORBED ARE CONSIDERED TO BE LOST,
 6910 !GRD SO WE GIVE THEM A LARGE OFFSET
 6911              if (part_abs(j).ne.0) then
 6912                 xgrd(j)  = 99.5d0
 6913                 ygrd(j)  = 99.5d0
 6914              endif
 6915         end do
 6916 !
 6917 !++  For LAST ELEMENT in the ring calculate the number of surviving
 6918 !++  particles and save into file versus turn number
 6919 !
 6920         if (ie.eq.iu) then
 6921              nsurvive = 0
 6922              do j = 1, napx
 6923                 if (xgrd(j).lt.99d0 .and. ygrd(j).lt.99d0) then
 6924                         nsurvive = nsurvive + 1
 6925                 endif
 6926              end do
 6927              write(44,*) iturn, nsurvive
 6928              if (iturn.eq.numl) then
 6929                 nsurvive_end = nsurvive_end + nsurvive
 6930              endif
 6931         endif
 6932 !
 6933 !=======================================================================
 6934 !++  Do collimation analysis at element 20 ("zero" turn) or LAST
 6935 !++  ring element.
 6936 !
 6937 !++  If selecting, look at number of scattered particles at selected
 6938 !++  collimator. For the "zero" turn consider the information at element
 6939 !++  20 (before collimation), otherwise take information at last ring
 6940 !++  element.
 6941 !
 6942         if (do_coll .and.                                               &
 6943      &  (  (iturn.eq.1 .and. ie.eq.20) .or.                             &
 6944      &  (ie.eq.iu)  )    ) then
 6945 !
 6946 !++  Calculate gammas
 6947 !------------------------------------------------------------------------
 6948 !
 6949           gammax = (1 + talphax(ie)**2)/tbetax(ie)
 6950           gammay = (1 + talphay(ie)**2)/tbetay(ie)
 6951 !
 6952 !________________________________________________________________________
 6953 !++  Loop over all particles.
 6954 !
 6955           do j = 1, napx
 6956 !
 6957 !------------------------------------------------------------------------
 6958 !++  Save initial distribution of particles that were scattered on
 6959 !++  the first turn at the selected primary collimator
 6960 !
 6961 !------------------------------------------------------------------------
 6962 !++  Do the binning in amplitude, only considering particles that were
 6963 !++  not absorbed before.
 6964 !
 6965             if (xgrd(j).lt.99d0 .and. ygrd(j) .lt.99d0 .and.            &
 6966      &      (part_select(j).eq.1 .or. ie.eq.20)) then
 6967 !
 6968 !++  Normalized amplitudes are calculated
 6969 !
 6970 !++  Allow to apply some dispersive offset. Take arc dispersion (2m) and
 6971 !++  normalize with arc beta_x function (180m).
 6972 !
 6973               arcdx    = 2.5d0
 6974               arcbetax = 180d0
 6975               xdisp = abs(xgrd(j)*1d-3) +                               &
 6976      &        abs((pgrd(j)-myenom)/myenom)*arcdx                        &
 6977      &        * sqrt(tbetax(ie)/arcbetax)
 6978               nspx    = sqrt(                                           &
 6979      &        abs(gammax*xdisp**2 +                                     &
 6980      &        2d0*talphax(ie)*xdisp*(xpgrd(j)*1d-3)+                    &
 6981      &        tbetax(ie)*(xpgrd(j)*1d-3)**2 )/myemitx0                  &
 6982      &        )
 6983               nspy    = sqrt(                                           &
 6984      &        abs( gammay*(ygrd(j)*1d-3)**2 +                           &
 6985      &        2d0*talphay(ie)*(ygrd(j)*1d-3*ypgrd(j)*1d-3)              &
 6986      &        + tbetay(ie)*(ypgrd(j)*1d-3)**2 )/myemity0                &
 6987      &        )
 6988 !
 6989 !++  Populate the efficiency arrays at the end of each turn...
 6990 !
 6991               if (ie.eq.iu) then
 6992                 do ieff = 1, numeff
 6993                   if (counted_r(j,ieff).eq.0 .and.                      &
 6994      &sqrt(                                                             &
 6995      &((xineff(j)*1d-3)**2                                              &
 6996      &/                                                                 &
 6997      &(tbetax(ie)*myemitx0))                                            &
 6998      &+                                                                 &
 6999      &((yineff(j)*1d-3)**2                                              &
 7000      &/                                                                 &
 7001      &(tbetay(ie)*myemity0))                                            &
 7002      &).ge.rsig(ieff)) then
 7003                     neff(ieff) = neff(ieff)+1d0
 7004                     counted_r(j,ieff)=1
 7005                   endif
 7006                   if (counted_x(j,ieff).eq.0 .and.                      &
 7007      &sqrt(                                                             &
 7008      &((xineff(j)*1d-3)**2                                              &
 7009      &/                                                                 &
 7010      &(tbetax(ie)*myemitx0))                                            &
 7011      &).ge.rsig(ieff)) then
 7012                     neffx(ieff) = neffx(ieff) + 1d0
 7013                     counted_x(j,ieff)=1
 7014                   endif
 7015                   if (counted_y(j,ieff).eq.0 .and.
 7016      &sqrt(                                                             &
 7017      &((yineff(j)*1d-3)**2                                              &
 7018      &/                                                                 &
 7019      &(tbetay(ie)*myemity0))                                            &
 7020      &).ge.rsig(ieff)) then
 7021                     neffy(ieff) = neffy(ieff) + 1d0
 7022                     counted_y(j,ieff)=1
 7023                   endif
 7024 !
 7025                 end do
 7026               endif
 7027 !
 7028 !++  Do an emittance drift
 7029 !
 7030               driftx = driftsx*sqrt(tbetax(ie)*myemitx0)
 7031               drifty = driftsy*sqrt(tbetay(ie)*myemity0)
 7032               if (ie.eq.iu) then
 7033                 dnormx  = driftx / sqrt(tbetax(ie)*myemitx0)
 7034                 dnormy  = drifty / sqrt(tbetay(ie)*myemity0)
 7035                 xnorm  = (xgrd(j)*1d-3) / sqrt(tbetax(ie)*myemitx0)
 7036                 xpnorm = (talphax(ie)*(xgrd(j)*1d-3)+                   &
 7037      &tbetax(ie)*(xpgrd(j)*1d-3)) /                                     &
 7038      &sqrt(tbetax(ie)*myemitx0)
 7039                 if((xnorm.ne.0d0).and.(xpnorm.ne.0d0)) then
 7040                     xangle = atan2(xnorm,xpnorm)
 7041                 else
 7042                     xangle=0
 7043                 endif    
 7044                 xnorm  = xnorm  + dnormx*sin(xangle)
 7045                 xpnorm = xpnorm + dnormx*cos(xangle)
 7046                 xgrd(j)   = 1000d0*(xnorm * sqrt(tbetax(ie)*myemitx0))
 7047                 xpgrd(j)  = 1000d0*((xpnorm*sqrt(tbetax(ie)*myemitx0)
 7048      &-talphax(ie)*xgrd(j)*1d-3)/tbetax(ie))
 7049 !
 7050  
 7051                 ynorm  = (ygrd(j)*1d-3)  / sqrt(tbetay(ie)*myemity0)
 7052                 ypnorm = (talphay(ie)*(ygrd(j)*1d-3)+                   &
 7053      &tbetay(ie)*(ypgrd(j)*1d-3)) /                                     &
 7054      &sqrt(tbetay(ie)*myemity0)
 7055                 if((ynorm.ne.0d0).and.(ypnorm.ne.0d0)) then
 7056                     yangle = atan2(ynorm,ypnorm)
 7057                 else
 7058                     yangle=0
 7059                 endif    
 7060                 ynorm  = ynorm  + dnormy*sin(yangle)
 7061                 ypnorm = ypnorm + dnormy*cos(yangle)
 7062                 ygrd(j)   = 1000d0*(ynorm * sqrt(tbetay(ie)*myemity0))
 7063                 ypgrd(j)  = 1000d0*((ypnorm*sqrt(tbetay(ie)*myemity0)   &
 7064      &-talphay(ie)*ygrd(j)*1d-3)/tbetay(ie))
 7065                 endif
 7066 !
 7067 !------------------------------------------------------------------------
 7068 !++  End of check for selection flag and absorption
 7069 !
 7070             endif
 7071 !
 7072 !++  End of do loop over particles
 7073 !
 7074           end do
 7075 !
 7076 !_________________________________________________________________
 7077 !
 7078 !++  End of collimation efficiency analysis for selected particles
 7079 !
 7080         end if
 7081 !------------------------------------------------------------------
 7082 !++  For LAST ELEMENT in the ring compact the arrays by moving all
 7083 !++  lost particles to the end of the array.
 7084 !
 7085         if (ie.eq.iu) then
 7086           imov = 0
 7087           do j = 1, napx
 7088             if (xgrd(j).lt.99d0 .and. ygrd(j).lt.99d0) then
 7089               imov = imov + 1
 7090               xgrd(imov)           = xgrd(j)
 7091               ygrd(imov)           = ygrd(j)
 7092               xpgrd(imov)          = xpgrd(j)
 7093               ypgrd(imov)          = ypgrd(j)
 7094               pgrd(imov)           = pgrd(j)
 7095               ejfvgrd(imov)        = ejfvgrd(j)
 7096               sigmvgrd(imov)       = sigmvgrd(j)
 7097               rvvgrd(imov)         = rvvgrd(j)
 7098               dpsvgrd(imov)        = dpsvgrd(j)
 7099               oidpsvgrd(imov)      = oidpsvgrd(j)
 7100               dpsv1grd(imov)       = dpsv1grd(j)
 7101               part_hit(imov)    = part_hit(j)
 7102               part_abs(imov)    = part_abs(j)
 7103               part_select(imov) = part_select(j)
 7104               part_impact(imov) = part_impact(j)
 7105               part_indiv(imov)  = part_indiv(j)
 7106               part_linteract(imov)  = part_linteract(j)
 7107               part_hit_before(imov) = part_hit_before(j)
 7108               secondary(imov) = secondary(j)
 7109               tertiary(imov) = tertiary(j)
 7110 !GRD HERE WE ADD A MARKER FOR THE PARTICLE FORMER NAME
 7111               ipart(imov) = ipart(j)
 7112               flukaname(imov) = flukaname(j)
 7113               do ieff = 1, numeff
 7114                 counted_r(imov,ieff) = counted_r(j,ieff)
 7115                 counted_x(imov,ieff) = counted_x(j,ieff)
 7116                 counted_y(imov,ieff) = counted_y(j,ieff)
 7117               end do
 7118             endif
 7119           end do
 7120           write(*,*) 'INFO>  Compacted the particle distributions: ',   &
 7121      &napx, ' -->  ', imov
 7122           napx = imov
 7123         endif
 7124 !GRD
 7125 !
 7126 !------------------------------------------------------------------------
 7127 !
 7128 !++  Write final distribution
 7129 !
 7130       if (dowrite_dist.and.(ie.eq.iu).and.(n.eq.numl)) then
 7131         open(unit=99, file='distn.dat')
 7132         write(99,*)                                                     &
 7133      &'# 1=x 2=xp 3=y 4=yp'
 7134         do j = 1, napx
 7135           write(99,'(5(1X,E15.7))') xgrd(j), xpgrd(j),                  &
 7136      &ygrd(j), ypgrd(j)
 7137 !     2             , S(J)
 7138         end do
 7139         close(99)
 7140       endif
 7141 !
 7142 !GRD
 7143 !GRD NOW ONE HAS TO COPY BACK THE NEW DISTRIBUTION TO ITS "ORIGINAL NAME"
 7144 !GRD AT THE END OF EACH TURN
 7145 !GRD
 7146       if (ie.eq.iu) then
 7147          do j = 1,napx
 7148             xv(1,j) = xgrd(j)
 7149             yv(1,j) = xpgrd(j)
 7150             xv(2,j) = ygrd(j)
 7151             yv(2,j) = ypgrd(j)
 7152             ejv(j)  = pgrd(j)
 7153             ejfv(j)   = ejfvgrd(j)
 7154             sigmv(j)  = sigmvgrd(j)
 7155             rvv(j)    = rvvgrd(j)
 7156             dpsv(j)   = dpsvgrd(j)
 7157             oidpsv(j) = oidpsvgrd(j)
 7158             dpsv1(j)  = dpsv1grd(j)
 7159          end do
 7160       endif
 7161          if (firstrun) then
 7162        if (rselect.gt.0 .and. rselect.lt.65) then
 7163             do j = 1, napx
 7164 !
 7165               xj     = (xv(1,j)-torbx(ie))/1d3
 7166               xpj    = (yv(1,j)-torbxp(ie))/1d3
 7167               yj     = (xv(2,j)-torby(ie))/1d3
 7168               ypj    = (yv(2,j)-torbyp(ie))/1d3
 7169               pj     = ejv(j)/1d3
 7170               if (iturn.eq.1.and.j.eq.1) then
 7171               sum_ax(ie)=0d0
 7172               sum_ay(ie)=0d0
 7173               endif
 7174               if (tbetax(ie).gt.0.) then
 7175           gammax = (1d0 + talphax(ie)**2)/tbetax(ie)
 7176                 gammay = (1d0 + talphay(ie)**2)/tbetay(ie)
 7177               else
 7178           gammax = (1d0 + talphax(ie-1)**2)/tbetax(ie-1)
 7179           gammay = (1d0 + talphay(ie-1)**2)/tbetay(ie-1)
 7180               endif
 7181 !
 7182               if (part_abs(j).eq.0) then
 7183                 if(tbetax(ie).gt.0.) then
 7184           nspx    = sqrt(                                               &
 7185      &abs( gammax*(xj)**2 +                                             &
 7186      &2d0*talphax(ie)*xj*xpj +                                          &
 7187      &tbetax(ie)*xpj**2 )/myemitx0                                      &
 7188      &)
 7189                 nspy    = sqrt(                                         &
 7190      &abs( gammay*(yj)**2 +                                             &
 7191      &2d0*talphay(ie)*yj*ypj +                                          &
 7192      &tbetay(ie)*ypj**2 )/myemity0                                      &
 7193      &)
 7194                 else
 7195           nspx    = sqrt(                                               &
 7196      &abs( gammax*(xj)**2 +                                             &
 7197      &2d0*talphax(ie-1)*xj*xpj +                                        &
 7198      &tbetax(ie-1)*xpj**2 )/myemitx0                                    &
 7199      &)
 7200                 nspy    = sqrt(                                         &
 7201      &abs( gammay*(yj)**2 +                                             &
 7202      &2d0*talphay(ie-1)*yj*ypj +                                        &
 7203      &tbetay(ie-1)*ypj**2 )/myemity0                                    &
 7204      &)
 7205                 endif
 7206 !
 7207           
 7208           xdebug(ie)=xj
 7209           xpdebug(ie)=xpj
 7210           ydebug(ie)=yj
 7211           ypdebug(ie)=ypj
 7212           xdebugN(ie)= xdebug(ie)/sqrt(myemitx0*tbetax(ie))
 7213           xpdebugN(ie)=(xdebug(ie)*talphax(ie)+xpdebug(ie)*tbetax(ie))
 7214      &    /sqrt(myemitx0*tbetax(ie))
 7215           ydebugN(ie)=ydebug(ie)/sqrt(myemity0*tbetay(ie))
 7216           ypdebugN(ie)=(ydebug(ie)*talphay(ie)+ypdebug(ie)*tbetay(ie))
 7217      &    /sqrt(myemity0*tbetay(ie))
 7218           
 7219                 sum_ax(ie)   = sum_ax(ie) + nspx
 7220                 sqsum_ax(ie) = sqsum_ax(ie) + nspx**2
 7221                 sum_ay(ie)   = sum_ay(ie) + nspy
 7222                 sqsum_ay(ie) = sqsum_ay(ie) + nspy**2
 7223                 nampl(ie)    = nampl(ie) + 1
 7224                 sampl(ie)    = totals
 7225                 ename(ie)    = bez(myix)(1:16)
 7226               else
 7227                 nspx = 0d0
 7228                 nspy = 0d0
 7229               endif
 7230             end do
 7231           endif
 7232          endif
 7233 !GRD
 7234 !GRD THIS LOOP MUST NOT BE WRITTEN INTO THE "IF(FIRSTRUN)" LOOP !!!!
 7235 !GRD
 7236           if (dowritetracks) then
 7237             do j = 1, napx
 7238               xj     = (xv(1,j)-torbx(ie))/1d3
 7239               xpj    = (yv(1,j)-torbxp(ie))/1d3
 7240               yj     = (xv(2,j)-torby(ie))/1d3
 7241               ypj    = (yv(2,j)-torbyp(ie))/1d3
 7242 !
 7243               arcdx = 2.5d0
 7244               arcbetax = 180d0
 7245 !
 7246                 if (xj.le.0.) then
 7247                   xdisp = xj + (pj-myenom)/myenom * arcdx               &
 7248      &* sqrt(tbetax(ie)/arcbetax)
 7249                 else
 7250                   xdisp = xj - (pj-myenom)/myenom * arcdx               &
 7251      &* sqrt(tbetax(ie)/arcbetax)
 7252                 endif
 7253                 xndisp = xj
 7254                 nspxd   = sqrt(                                         &
 7255      &abs(gammax*xdisp**2 + 2d0*talphax(ie)*xdisp*xpj                   &
 7256      &+ tbetax(ie)*xpj**2)/myemitx0                                     &
 7257      &)
 7258                 nspx    = sqrt(                                         &
 7259      &abs( gammax*xndisp**2 + 2d0*talphax(ie)*xndisp*                   &
 7260      &xpj + tbetax(ie)*xpj**2 )/myemitx0                                &
 7261      &)
 7262                 nspy    = sqrt(                                         &
 7263      &abs( gammay*yj**2 + 2d0*talphay(ie)*yj                            &
 7264      &*ypj + tbetay(ie)*ypj**2 )/myemity0                               &
 7265      &)
 7266 !
 7267 !
 7268 !
 7269          if(part_abs(j).eq.0) then
 7270         if ((secondary(j).eq.1.or.tertiary(j).eq.2.or.other(j).eq.4)    &
 7271      &.and.(xv(1,j).lt.99d0 .and. xv(2,j).lt.99d0) .and.                &
 7272 !GRD
 7273 !GRD HERE WE APPLY THE SAME KIND OF CUT THAN THE SIGSECUT PARAMETER
 7274 !GRD                                                                    &
 7275      &(                                                                 &
 7276      &((                                                                &
 7277      &(xv(1,j)*1d-3)**2                                                 &
 7278      &/                                                                 &
 7279      &(tbetax(ie)*myemitx0)                                             &
 7280      &).ge.dble(sigsecut2)).or.                                         &
 7281      &((                                                                &
 7282      &(xv(2,j)*1d-3)**2                                                 &
 7283      &/                                                                 &
 7284      &(tbetay(ie)*myemity0)                                             &
 7285      &).ge.dble(sigsecut2)).or.                                         &
 7286      &(((xv(1,j)*1d-3)**2/(tbetax(ie)*myemitx0))+                       &
 7287      &((xv(2,j)*1d-3)**2/(tbetay(ie)*myemity0))                         &
 7288      &.ge.sigsecut3)                                                    &
 7289      &) ) then
 7290                 xj     = (xv(1,j)-torbx(ie))/1d3
 7291                 xpj    = (yv(1,j)-torbxp(ie))/1d3
 7292                 yj     = (xv(2,j)-torby(ie))/1d3
 7293                 ypj    = (yv(2,j)-torbyp(ie))/1d3
 7294           write(38,'(1x,i8,1x,i4,1x,f8.2,5(1x,e11.3),1x,i4)')           &
 7295      &ipart(j)+100*samplenumber,iturn,sampl(ie),                        &
 7296      &xv(1,j),yv(1,j),                                                  &
 7297      &xv(2,j),yv(2,j),(ejv(j)-myenom)/myenom,                           &
 7298      &secondary(j)+tertiary(j)+other(j)
 7299               endif
 7300          endif
 7301             end do
 7302           endif
 7303 !=======================================================================
 7304 !GRD END OF UPGRADE
 7305   660 continue
 7306       close(99)
 7307       close(53)
 7308 !GRD HERE WE SET THE FLAG FOR INITIALIZATION TO FALSE AFTER TURN 1
 7309       firstrun = .false.
 7310       return
 7311       end
 7312 !
 7313 !==============================================================================
 7314 !
 7315       subroutine thin6dua(nthinerr)
 7316 !-----------------------------------------------------------------------
 7317 !
 7318 !  TRACK THIN LENS 6D WITH ACCELERATION
 7319 !
 7320 !
 7321 !  F. SCHMIDT
 7322 !-----------------------------------------------------------------------
 7323       implicit none
 7324       integer i,irrtr,ix,j,k,kpz,n,nmz,nthinerr
 7325       double precision c5m4,cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,   &
 7326      &crkveuk,crxb,crzb,dpsv3,pux,e0fo,e0o,r0,r2b,rb,rho2b,rkb,stracki, &
 7327      &tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
 7328       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 7329      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 7330      &nrco,ntr,nzfz
 7331       parameter(npart = 64,nmac = 1)
 7332       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 7333      &nzfz = 300000,mmul = 11)
 7334       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 7335      &nema = 15)
 7336       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 7337       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 7338       parameter(nmon1 = 600,ncor1 = 600)
 7339       parameter(ntr = 20,nbb = 160)
 7340       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
 7341       double precision xv1j,xv2j
 7342       double precision acdipamp, qd, acphase,acdipamp2,                 &
 7343      &acdipamp1
 7344       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
 7345       logical llost
 7346       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 7347      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 7348      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 7349      &one,pieni,pmae,pmap,three,two,zero
 7350       parameter(pieni = 1d-38)
 7351       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 7352       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 7353       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 7354       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 7355       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 7356      &1.0d16)
 7357       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 7358       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 7359       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 7360       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 7361       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 7362       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 7363       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 7364       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 7365       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 7366      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 7367      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 7368      &imc,imtr,iorg,iout,                                               &
 7369      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 7370      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 7371      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 7372      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 7373      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 7374      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 7375      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 7376      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 7377      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 7378       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 7379      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 7380      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 7381      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 7382      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 7383      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 7384      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 7385      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 7386      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 7387      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 7388      &acdipph
 7389       real hmal
 7390       character*16 bez,bezb,bezr,erbez,bezl
 7391       character*80 toptit,sixtit,commen
 7392       common/erro/ierro,erbez
 7393       common/kons/pi,pi2,pisqrt,rad
 7394       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 7395       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 7396       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 7397       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 7398       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 7399       common/syos2/rvf(mpa)
 7400       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 7401      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 7402       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 7403      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 7404      &iicav,itionc(nele),ition,idp,ncy,ixcav
 7405       common/corcom/dpscor,sigcor,icode,idam,its6d
 7406       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 7407      &bka(nele,mmul),aka(nele,mmul)
 7408       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 7409       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 7410       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 7411      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 7412       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 7413       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 7414      &iout
 7415       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 7416       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 7417      &ntco,eui,euii,nlin,bezl(nele)
 7418       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 7419      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 7420      &ncororb(nele)
 7421       common/apert/apx(nele),apz(nele),ape(3,nele)
 7422       common/clos/sigma0(2),iclo,ncorru,ncorrep
 7423       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 7424      &ratioe(nele),iratioe(nele),icoe
 7425       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 7426       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 7427       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 7428       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 7429       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 7430      &nstart,nstop,iskip,iconv,imad
 7431       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 7432       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 7433       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 7434       common/ripp2/nrturn
 7435       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 7436       common/pawc/hmal(nplo)
 7437       common/tit/sixtit,commen,ithick
 7438       common/co6d/clo6(3),clop6(3)
 7439       common/dkic/dki(nele,3)
 7440       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 7441      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 7442      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 7443      &nbeam,ibbc,ibeco,ibtyp,lhc
 7444       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 7445       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 7446       common/wireco/ wirel(nele)
 7447       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 7448      &nturn3(nele), nturn4(nele)
 7449       integer idz,itra
 7450       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 7451       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 7452      &dps(mpa),idz(2)
 7453       common/anf/chi0,chid,exz(2,6),dp1,itra
 7454       integer ichrom,is
 7455       double precision alf0,amp,bet0,clo,clop,cro,x,y
 7456       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 7457       common/chrom/cro(2),is(2),ichrom
 7458       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 7459      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 7460       double precision dpmax,preda,weig1,weig2
 7461       character*16 coel
 7462       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 7463       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 7464       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 7465      &coel(10)
 7466       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 7467      &zsi
 7468       real tlim,time0,time1
 7469       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 7470      &aai(nblz,mmul),bbi(nblz,mmul)
 7471       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 7472       common/damp/damp,ampt
 7473       common/ttime/tlim,time0,time1
 7474       double precision tasm
 7475       common/tasm/tasm(6,6)
 7476       integer iv,ixv,nlostp,nms,numxv
 7477       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 7478      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 7479      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 7480      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 7481      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 7482      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 7483      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 7484      &zsiv,zsv
 7485       logical pstop
 7486       common/main1/                                                     &
 7487      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 7488      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 7489      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 7490      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 7491      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 7492      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 7493      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 7494      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 7495       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 7496      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 7497      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 7498      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 7499      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 7500      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 7501      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 7502      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 7503      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 7504       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 7505      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 7506      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 7507      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 7508       integer numx
 7509       double precision e0f
 7510       common/main4/ e0f,numx
 7511       integer ktrack,nwri
 7512       double precision dpsv1,strack,strackc,stracks
 7513       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 7514      &stracks(nblz),dpsv1(npart),nwri
 7515       double precision cc,xlim,ylim
 7516       parameter(cc = 1.12837916709551d0)
 7517       parameter(xlim = 5.33d0)
 7518       parameter(ylim = 4.29d0)
 7519       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
 7520      &r2b(npart),rb(npart),rkb(npart),                                  &
 7521      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
 7522      &crzb(npart),cbxb(npart),cbzb(npart)
 7523       dimension dpsv3(npart)
 7524       save
 7525 !-----------------------------------------------------------------------
 7526       c5m4=5.0d-4
 7527       nthinerr=0
 7528       do 660 n=1,numl
 7529         numx=n-1
 7530         if(irip.eq.1) call ripple(n)
 7531         if(n.le.nde(1)) nwri=nwr(1)
 7532         if(n.gt.nde(1).and.n.le.nde(2)) nwri=nwr(2)
 7533         if(n.gt.nde(2)) nwri=nwr(3)
 7534         if(nwri.eq.0) nwri=numl+numlr+1
 7535         if(mod(numx,nwri).eq.0) call writebin(nthinerr)
 7536         if(nthinerr.ne.0) return
 7537         do 650 i=1,iu
 7538           ix=ic(i)-nblo
 7539 !--------count44
 7540           goto(10,30,740,650,650,650,650,650,650,650,50,70,90,110,130,  &
 7541      &150,170,190,210,230,440,460,480,500,520,540,560,580,600,620,      &
 7542      &640,410,250,270,290,310,330,350,370,390,680,700,720,730,748,      &
 7543      &650,650,650,650,650,745,746),ktrack(i)
 7544           goto 650
 7545    10     stracki=strack(i)
 7546           do 20 j=1,napx
 7547             xv(1,j)=xv(1,j)+stracki*yv(1,j)
 7548             xv(2,j)=xv(2,j)+stracki*yv(2,j)
 7549             sigmv(j)=sigmv(j)+stracki*(c1e3-rvv(j)*(c1e3+(yv(1,j)       &
 7550      &*yv(1,j)+yv(2,j)*yv(2,j))*c5m4))
 7551    20     continue
 7552           goto 650
 7553    30     e0o=e0
 7554           e0fo=e0f
 7555           call adia(n,e0f)
 7556           do 40 j=1,napx
 7557             ejf0v(j)=ejfv(j)
 7558             if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
 7559             if(sigmv(j).lt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
 7560             if(kz(ix).eq.12) then
 7561               ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+phas+          &
 7562      &phasc(ix))
 7563             else
 7564               ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j)+phas)
 7565             endif
 7566             ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
 7567             rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
 7568             dpsv(j)=(ejfv(j)-e0f)/e0f
 7569             oidpsv(j)=one/(one+dpsv(j))
 7570             dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
 7571             if(sigmv(j).gt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
 7572             yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
 7573    40     yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
 7574           if(n.eq.1) write(98,'(1p,6(2x,e25.18))')                      &
 7575      &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),j=1,napx)
 7576           goto 640
 7577 !--HORIZONTAL DIPOLE
 7578    50     do 60 j=1,napx
 7579             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
 7580             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
 7581    60     continue
 7582           goto 640
 7583 !--NORMAL QUADRUPOLE
 7584    70     do 80 j=1,napx
 7585             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7586      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7587             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7588      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7589             crkve=xlv(j)
 7590             cikve=zlv(j)
 7591             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7592      &stracks(i)*cikve)
 7593             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7594      &stracks(i)*crkve)
 7595    80     continue
 7596           goto 640
 7597 !--NORMAL SEXTUPOLE
 7598    90     do 100 j=1,napx
 7599             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7600      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7601             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7602      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7603             crkve=xlv(j)
 7604             cikve=zlv(j)
 7605            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7606            cikve=crkve*zlv(j)+cikve*xlv(j)
 7607            crkve=crkveuk
 7608             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7609      &stracks(i)*cikve)
 7610             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7611      &stracks(i)*crkve)
 7612   100     continue
 7613           goto 640
 7614 !--NORMAL OCTUPOLE
 7615   110     do 120 j=1,napx
 7616             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7617      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7618             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7619      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7620             crkve=xlv(j)
 7621             cikve=zlv(j)
 7622            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7623            cikve=crkve*zlv(j)+cikve*xlv(j)
 7624            crkve=crkveuk
 7625            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7626            cikve=crkve*zlv(j)+cikve*xlv(j)
 7627            crkve=crkveuk
 7628             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7629      &stracks(i)*cikve)
 7630             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7631      &stracks(i)*crkve)
 7632   120     continue
 7633           goto 640
 7634 !--NORMAL DECAPOLE
 7635   130     do 140 j=1,napx
 7636             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7637      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7638             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7639      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7640             crkve=xlv(j)
 7641             cikve=zlv(j)
 7642            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7643            cikve=crkve*zlv(j)+cikve*xlv(j)
 7644            crkve=crkveuk
 7645            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7646            cikve=crkve*zlv(j)+cikve*xlv(j)
 7647            crkve=crkveuk
 7648            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7649            cikve=crkve*zlv(j)+cikve*xlv(j)
 7650            crkve=crkveuk
 7651             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7652      &stracks(i)*cikve)
 7653             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7654      &stracks(i)*crkve)
 7655   140     continue
 7656           goto 640
 7657 !--NORMAL DODECAPOLE
 7658   150     do 160 j=1,napx
 7659             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7660      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7661             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7662      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7663             crkve=xlv(j)
 7664             cikve=zlv(j)
 7665            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7666            cikve=crkve*zlv(j)+cikve*xlv(j)
 7667            crkve=crkveuk
 7668            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7669            cikve=crkve*zlv(j)+cikve*xlv(j)
 7670            crkve=crkveuk
 7671            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7672            cikve=crkve*zlv(j)+cikve*xlv(j)
 7673            crkve=crkveuk
 7674            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7675            cikve=crkve*zlv(j)+cikve*xlv(j)
 7676            crkve=crkveuk
 7677             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7678      &stracks(i)*cikve)
 7679             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7680      &stracks(i)*crkve)
 7681   160     continue
 7682           goto 640
 7683 !--NORMAL 14-POLE
 7684   170     do 180 j=1,napx
 7685             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7686      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7687             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7688      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7689             crkve=xlv(j)
 7690             cikve=zlv(j)
 7691            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7692            cikve=crkve*zlv(j)+cikve*xlv(j)
 7693            crkve=crkveuk
 7694            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7695            cikve=crkve*zlv(j)+cikve*xlv(j)
 7696            crkve=crkveuk
 7697            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7698            cikve=crkve*zlv(j)+cikve*xlv(j)
 7699            crkve=crkveuk
 7700            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7701            cikve=crkve*zlv(j)+cikve*xlv(j)
 7702            crkve=crkveuk
 7703            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7704            cikve=crkve*zlv(j)+cikve*xlv(j)
 7705            crkve=crkveuk
 7706             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7707      &stracks(i)*cikve)
 7708             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7709      &stracks(i)*crkve)
 7710   180     continue
 7711           goto 640
 7712 !--NORMAL 16-POLE
 7713   190     do 200 j=1,napx
 7714             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7715      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7716             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7717      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7718             crkve=xlv(j)
 7719             cikve=zlv(j)
 7720            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7721            cikve=crkve*zlv(j)+cikve*xlv(j)
 7722            crkve=crkveuk
 7723            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7724            cikve=crkve*zlv(j)+cikve*xlv(j)
 7725            crkve=crkveuk
 7726            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7727            cikve=crkve*zlv(j)+cikve*xlv(j)
 7728            crkve=crkveuk
 7729            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7730            cikve=crkve*zlv(j)+cikve*xlv(j)
 7731            crkve=crkveuk
 7732            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7733            cikve=crkve*zlv(j)+cikve*xlv(j)
 7734            crkve=crkveuk
 7735            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7736            cikve=crkve*zlv(j)+cikve*xlv(j)
 7737            crkve=crkveuk
 7738             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7739      &stracks(i)*cikve)
 7740             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7741      &stracks(i)*crkve)
 7742   200     continue
 7743           goto 640
 7744 !--NORMAL 18-POLE
 7745   210     do 220 j=1,napx
 7746             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7747      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7748             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7749      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7750             crkve=xlv(j)
 7751             cikve=zlv(j)
 7752            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7753            cikve=crkve*zlv(j)+cikve*xlv(j)
 7754            crkve=crkveuk
 7755            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7756            cikve=crkve*zlv(j)+cikve*xlv(j)
 7757            crkve=crkveuk
 7758            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7759            cikve=crkve*zlv(j)+cikve*xlv(j)
 7760            crkve=crkveuk
 7761            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7762            cikve=crkve*zlv(j)+cikve*xlv(j)
 7763            crkve=crkveuk
 7764            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7765            cikve=crkve*zlv(j)+cikve*xlv(j)
 7766            crkve=crkveuk
 7767            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7768            cikve=crkve*zlv(j)+cikve*xlv(j)
 7769            crkve=crkveuk
 7770            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7771            cikve=crkve*zlv(j)+cikve*xlv(j)
 7772            crkve=crkveuk
 7773             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7774      &stracks(i)*cikve)
 7775             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7776      &stracks(i)*crkve)
 7777   220     continue
 7778           goto 640
 7779 !--NORMAL 20-POLE
 7780   230     do 240 j=1,napx
 7781             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7782      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7783             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7784      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7785             crkve=xlv(j)
 7786             cikve=zlv(j)
 7787            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7788            cikve=crkve*zlv(j)+cikve*xlv(j)
 7789            crkve=crkveuk
 7790            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7791            cikve=crkve*zlv(j)+cikve*xlv(j)
 7792            crkve=crkveuk
 7793            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7794            cikve=crkve*zlv(j)+cikve*xlv(j)
 7795            crkve=crkveuk
 7796            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7797            cikve=crkve*zlv(j)+cikve*xlv(j)
 7798            crkve=crkveuk
 7799            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7800            cikve=crkve*zlv(j)+cikve*xlv(j)
 7801            crkve=crkveuk
 7802            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7803            cikve=crkve*zlv(j)+cikve*xlv(j)
 7804            crkve=crkveuk
 7805            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7806            cikve=crkve*zlv(j)+cikve*xlv(j)
 7807            crkve=crkveuk
 7808            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7809            cikve=crkve*zlv(j)+cikve*xlv(j)
 7810            crkve=crkveuk
 7811             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7812      &stracks(i)*cikve)
 7813             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
 7814      &stracks(i)*crkve)
 7815   240     continue
 7816           goto 640
 7817   250     continue
 7818           do 260 j=1,napx
 7819             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7820      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7821             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7822      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7823             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 7824      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 7825      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 7826             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 7827      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 7828      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 7829             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 7830   260     continue
 7831           goto 640
 7832   270     continue
 7833           do 280 j=1,napx
 7834             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7835      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7836             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7837      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7838             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
 7839      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
 7840      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 7841             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
 7842      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
 7843      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 7844             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 7845   280     continue
 7846           goto 410
 7847   290     continue
 7848           do 300 j=1,napx
 7849             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7850      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7851             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7852      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7853             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 7854      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 7855             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 7856      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 7857             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 7858   300     continue
 7859           goto 640
 7860   310     continue
 7861           do 320 j=1,napx
 7862             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7863      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7864             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7865      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7866             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
 7867      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
 7868             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
 7869      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
 7870             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
 7871   320     continue
 7872           goto 410
 7873   330     continue
 7874           do 340 j=1,napx
 7875             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7876      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7877             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7878      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7879             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 7880      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 7881      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 7882             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 7883      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 7884      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 7885             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 7886   340     continue
 7887           goto 640
 7888   350     continue
 7889           do 360 j=1,napx
 7890             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7891      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7892             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7893      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7894             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
 7895      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
 7896      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 7897             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
 7898      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
 7899      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 7900             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 7901   360     continue
 7902           goto 410
 7903   370     continue
 7904           do 380 j=1,napx
 7905             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7906      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7907             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7908      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7909             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 7910      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 7911             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 7912      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 7913             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 7914   380     continue
 7915           goto 640
 7916   390     continue
 7917           do 400 j=1,napx
 7918             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7919      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7920             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7921      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7922             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
 7923      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
 7924             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
 7925      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
 7926             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
 7927   400     continue
 7928   410     r0=ek(ix)
 7929           nmz=nmu(ix)
 7930           if(nmz.ge.2) then
 7931             do 430 j=1,napx
 7932             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
 7933      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7934             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
 7935      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7936               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
 7937               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
 7938               crkve=xlvj
 7939               cikve=zlvj
 7940                 do 420 k=3,nmz
 7941                   crkveuk=crkve*xlvj-cikve*zlvj
 7942                   cikve=crkve*zlvj+cikve*xlvj
 7943                   crkve=crkveuk
 7944                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
 7945                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
 7946   420           continue
 7947               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
 7948               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
 7949   430       continue
 7950           else
 7951             do 435 j=1,napx
 7952               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
 7953      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
 7954               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
 7955      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
 7956   435       continue
 7957           endif
 7958           goto 640
 7959 !--SKEW ELEMENTS
 7960 !--VERTICAL DIPOLE
 7961   440     do 450 j=1,napx
 7962             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
 7963             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
 7964   450     continue
 7965           goto 640
 7966 !--SKEW QUADRUPOLE
 7967   460     do 470 j=1,napx
 7968             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7969      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7970             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7971      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7972             crkve=xlv(j)
 7973             cikve=zlv(j)
 7974             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 7975      &stracks(i)*crkve)
 7976             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7977      &stracks(i)*cikve)
 7978   470     continue
 7979           goto 640
 7980 !--SKEW SEXTUPOLE
 7981   480     do 490 j=1,napx
 7982             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 7983      &(xv(2,j)-zsiv(1,i))*tilts(i)
 7984             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 7985      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 7986             crkve=xlv(j)
 7987             cikve=zlv(j)
 7988            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 7989            cikve=crkve*zlv(j)+cikve*xlv(j)
 7990            crkve=crkveuk
 7991             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 7992      &stracks(i)*crkve)
 7993             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 7994      &stracks(i)*cikve)
 7995   490     continue
 7996           goto 640
 7997 !--SKEW OCTUPOLE
 7998   500     do 510 j=1,napx
 7999             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8000      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8001             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8002      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8003             crkve=xlv(j)
 8004             cikve=zlv(j)
 8005            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8006            cikve=crkve*zlv(j)+cikve*xlv(j)
 8007            crkve=crkveuk
 8008            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8009            cikve=crkve*zlv(j)+cikve*xlv(j)
 8010            crkve=crkveuk
 8011             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8012      &stracks(i)*crkve)
 8013             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8014      &stracks(i)*cikve)
 8015   510     continue
 8016           goto 640
 8017 !--SKEW DECAPOLE
 8018   520     do 530 j=1,napx
 8019             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8020      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8021             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8022      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8023             crkve=xlv(j)
 8024             cikve=zlv(j)
 8025            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8026            cikve=crkve*zlv(j)+cikve*xlv(j)
 8027            crkve=crkveuk
 8028            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8029            cikve=crkve*zlv(j)+cikve*xlv(j)
 8030            crkve=crkveuk
 8031            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8032            cikve=crkve*zlv(j)+cikve*xlv(j)
 8033            crkve=crkveuk
 8034             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8035      &stracks(i)*crkve)
 8036             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8037      &stracks(i)*cikve)
 8038   530     continue
 8039           goto 640
 8040 !--SKEW DODECAPOLE
 8041   540     do 550 j=1,napx
 8042             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8043      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8044             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8045      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8046             crkve=xlv(j)
 8047             cikve=zlv(j)
 8048            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8049            cikve=crkve*zlv(j)+cikve*xlv(j)
 8050            crkve=crkveuk
 8051            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8052            cikve=crkve*zlv(j)+cikve*xlv(j)
 8053            crkve=crkveuk
 8054            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8055            cikve=crkve*zlv(j)+cikve*xlv(j)
 8056            crkve=crkveuk
 8057            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8058            cikve=crkve*zlv(j)+cikve*xlv(j)
 8059            crkve=crkveuk
 8060             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8061      &stracks(i)*crkve)
 8062             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8063      &stracks(i)*cikve)
 8064   550     continue
 8065           goto 640
 8066 !--SKEW 14-POLE
 8067   560     do 570 j=1,napx
 8068             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8069      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8070             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8071      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8072             crkve=xlv(j)
 8073             cikve=zlv(j)
 8074            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8075            cikve=crkve*zlv(j)+cikve*xlv(j)
 8076            crkve=crkveuk
 8077            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8078            cikve=crkve*zlv(j)+cikve*xlv(j)
 8079            crkve=crkveuk
 8080            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8081            cikve=crkve*zlv(j)+cikve*xlv(j)
 8082            crkve=crkveuk
 8083            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8084            cikve=crkve*zlv(j)+cikve*xlv(j)
 8085            crkve=crkveuk
 8086            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8087            cikve=crkve*zlv(j)+cikve*xlv(j)
 8088            crkve=crkveuk
 8089             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8090      &stracks(i)*crkve)
 8091             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8092      &stracks(i)*cikve)
 8093   570     continue
 8094           goto 640
 8095 !--SKEW 16-POLE
 8096   580     do 590 j=1,napx
 8097             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8098      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8099             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8100      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8101             crkve=xlv(j)
 8102             cikve=zlv(j)
 8103            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8104            cikve=crkve*zlv(j)+cikve*xlv(j)
 8105            crkve=crkveuk
 8106            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8107            cikve=crkve*zlv(j)+cikve*xlv(j)
 8108            crkve=crkveuk
 8109            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8110            cikve=crkve*zlv(j)+cikve*xlv(j)
 8111            crkve=crkveuk
 8112            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8113            cikve=crkve*zlv(j)+cikve*xlv(j)
 8114            crkve=crkveuk
 8115            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8116            cikve=crkve*zlv(j)+cikve*xlv(j)
 8117            crkve=crkveuk
 8118            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8119            cikve=crkve*zlv(j)+cikve*xlv(j)
 8120            crkve=crkveuk
 8121             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8122      &stracks(i)*crkve)
 8123             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8124      &stracks(i)*cikve)
 8125   590     continue
 8126           goto 640
 8127 !--SKEW 18-POLE
 8128   600     do 610 j=1,napx
 8129             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8130      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8131             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8132      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8133             crkve=xlv(j)
 8134             cikve=zlv(j)
 8135            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8136            cikve=crkve*zlv(j)+cikve*xlv(j)
 8137            crkve=crkveuk
 8138            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8139            cikve=crkve*zlv(j)+cikve*xlv(j)
 8140            crkve=crkveuk
 8141            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8142            cikve=crkve*zlv(j)+cikve*xlv(j)
 8143            crkve=crkveuk
 8144            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8145            cikve=crkve*zlv(j)+cikve*xlv(j)
 8146            crkve=crkveuk
 8147            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8148            cikve=crkve*zlv(j)+cikve*xlv(j)
 8149            crkve=crkveuk
 8150            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8151            cikve=crkve*zlv(j)+cikve*xlv(j)
 8152            crkve=crkveuk
 8153            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8154            cikve=crkve*zlv(j)+cikve*xlv(j)
 8155            crkve=crkveuk
 8156             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8157      &stracks(i)*crkve)
 8158             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8159      &stracks(i)*cikve)
 8160   610     continue
 8161           goto 640
 8162 !--SKEW 20-POLE
 8163   620     do 630 j=1,napx
 8164             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
 8165      &(xv(2,j)-zsiv(1,i))*tilts(i)
 8166             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
 8167      &(xv(2,j)-zsiv(1,i))*tiltc(i)
 8168             crkve=xlv(j)
 8169             cikve=zlv(j)
 8170            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8171            cikve=crkve*zlv(j)+cikve*xlv(j)
 8172            crkve=crkveuk
 8173            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8174            cikve=crkve*zlv(j)+cikve*xlv(j)
 8175            crkve=crkveuk
 8176            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8177            cikve=crkve*zlv(j)+cikve*xlv(j)
 8178            crkve=crkveuk
 8179            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8180            cikve=crkve*zlv(j)+cikve*xlv(j)
 8181            crkve=crkveuk
 8182            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8183            cikve=crkve*zlv(j)+cikve*xlv(j)
 8184            crkve=crkveuk
 8185            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8186            cikve=crkve*zlv(j)+cikve*xlv(j)
 8187            crkve=crkveuk
 8188            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8189            cikve=crkve*zlv(j)+cikve*xlv(j)
 8190            crkve=crkveuk
 8191            crkveuk=crkve*xlv(j)-cikve*zlv(j)
 8192            cikve=crkve*zlv(j)+cikve*xlv(j)
 8193            crkve=crkveuk
 8194             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
 8195      &stracks(i)*crkve)
 8196             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
 8197      &stracks(i)*cikve)
 8198   630     continue
 8199           goto 640
 8200   680     continue
 8201           do 690 j=1,napx
 8202               if(ibbc.eq.0) then
 8203                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 8204                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 8205               else
 8206                 crkveb(j)=                                              &
 8207      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 8208      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 8209                 cikveb(j)=                                              &
 8210      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 8211      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 8212               endif
 8213             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
 8214             if(rho2b(j).le.pieni)                                       &
 8215      &goto 690
 8216             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
 8217             if(ibbc.eq.0) then
 8218               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
 8219      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
 8220               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
 8221      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
 8222             else
 8223               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 8224      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
 8225      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 8226      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 8227               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 8228               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
 8229      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
 8230      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
 8231      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 8232               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 8233             endif
 8234   690     continue
 8235           goto 640
 8236   700     continue
 8237           if(ibtyp.eq.0) then
 8238             do j=1,napx
 8239               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 8240               rb(j)=sqrt(r2b(j))
 8241               rkb(j)=strack(i)*pisqrt/rb(j)
 8242               if(ibbc.eq.0) then
 8243                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 8244                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 8245               else
 8246                 crkveb(j)=                                              &
 8247      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 8248      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 8249                 cikveb(j)=                                              &
 8250      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 8251      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 8252               endif
 8253               xrb(j)=abs(crkveb(j))/rb(j)
 8254               zrb(j)=abs(cikveb(j))/rb(j)
 8255               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
 8256               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 8257      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 8258               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 8259               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 8260               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
 8261               if(ibbc.eq.0) then
 8262                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 8263      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 8264                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 8265      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 8266               else
 8267                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8268      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8269      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8270      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 8271                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 8272                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8273      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8274      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8275      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 8276                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 8277               endif
 8278             enddo
 8279           else if(ibtyp.eq.1) then
 8280             do j=1,napx
 8281               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
 8282               rb(j)=sqrt(r2b(j))
 8283               rkb(j)=strack(i)*pisqrt/rb(j)
 8284               if(ibbc.eq.0) then
 8285                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 8286                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 8287               else
 8288                 crkveb(j)=                                              &
 8289      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 8290      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 8291                 cikveb(j)=                                              &
 8292      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 8293      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 8294               endif
 8295               xrb(j)=abs(crkveb(j))/rb(j)
 8296               zrb(j)=abs(cikveb(j))/rb(j)
 8297               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 8298      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 8299               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 8300               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 8301             enddo
 8302             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
 8303             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
 8304             do j=1,napx
 8305               if(ibbc.eq.0) then
 8306                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 8307      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 8308                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 8309      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 8310               else
 8311                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8312      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8313      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8314      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 8315                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 8316                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8317      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8318      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8319      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 8320                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 8321               endif
 8322             enddo
 8323           endif
 8324           goto 640
 8325   720     continue
 8326           if(ibtyp.eq.0) then
 8327             do j=1,napx
 8328               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 8329               rb(j)=sqrt(r2b(j))
 8330               rkb(j)=strack(i)*pisqrt/rb(j)
 8331               if(ibbc.eq.0) then
 8332                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 8333                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 8334               else
 8335                 crkveb(j)=                                              &
 8336      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 8337      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 8338                 cikveb(j)=                                              &
 8339      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 8340      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 8341               endif
 8342               xrb(j)=abs(crkveb(j))/rb(j)
 8343               zrb(j)=abs(cikveb(j))/rb(j)
 8344               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
 8345               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 8346      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 8347               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 8348               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 8349               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
 8350               if(ibbc.eq.0) then
 8351                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 8352      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 8353                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 8354      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 8355               else
 8356                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8357      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8358      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8359      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 8360                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 8361                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8362      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8363      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8364      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 8365                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 8366               endif
 8367             enddo
 8368           else if(ibtyp.eq.1) then
 8369             do j=1,napx
 8370               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
 8371               rb(j)=sqrt(r2b(j))
 8372               rkb(j)=strack(i)*pisqrt/rb(j)
 8373               if(ibbc.eq.0) then
 8374                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
 8375                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
 8376               else
 8377                 crkveb(j)=                                              &
 8378      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
 8379      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
 8380                 cikveb(j)=                                              &
 8381      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
 8382      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
 8383               endif
 8384               xrb(j)=abs(crkveb(j))/rb(j)
 8385               zrb(j)=abs(cikveb(j))/rb(j)
 8386               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
 8387      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
 8388               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
 8389               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
 8390             enddo
 8391             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
 8392             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
 8393             do j=1,napx
 8394               if(ibbc.eq.0) then
 8395                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
 8396      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
 8397                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
 8398      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
 8399               else
 8400                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8401      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8402      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8403      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
 8404                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
 8405                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
 8406      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
 8407      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
 8408      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
 8409                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
 8410               endif
 8411             enddo
 8412           endif
 8413           goto 640
 8414   730     continue
 8415 !--Hirata's 6D beam-beam kick
 8416             do j=1,napx
 8417               track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
 8418               track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
 8419               track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
 8420               track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
 8421               track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
 8422               track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
 8423             enddo
 8424             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
 8425      &ibbc)
 8426             do j=1,napx
 8427               xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))-             &
 8428      &beamoff(1,imbb(i))
 8429               xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))-             &
 8430      &beamoff(2,imbb(i))
 8431               dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
 8432               oidpsv(j)=one/(one+dpsv(j))
 8433               yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))-            &
 8434      &beamoff(4,imbb(i)))*oidpsv(j)
 8435               yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))-            &
 8436      &beamoff(5,imbb(i)))*oidpsv(j)
 8437               ejfv(j)=dpsv(j)*e0f+e0f
 8438               ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
 8439               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
 8440               if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
 8441             enddo
 8442           goto 640
 8443   740     continue
 8444           irrtr=imtr(ix)
 8445           do j=1,napx
 8446             sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+    &
 8447      &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+                  &
 8448      &rrtr(irrtr,5,4)*yv(2,j)
 8449             pux=xv(1,j)
 8450             dpsv3(j)=dpsv(j)*c1e3
 8451             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
 8452      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
 8453             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
 8454      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
 8455             pux=xv(2,j)
 8456             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
 8457      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
 8458             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
 8459      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
 8460           enddo
 8461  
 8462 !----------------------------------------------------------------------
 8463  
 8464 ! Wire.
 8465  
 8466           goto 640
 8467   745     continue
 8468           xory=1
 8469           nfree=nturn1(ix)
 8470          if(n.gt.nfree) then
 8471           nac=n-nfree
 8472           pi=4d0*atan(1d0)
 8473 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 8474 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 8475           acdipamp=ed(ix)*clight*1.0d-3
 8476 !---------Qd input in tune units
 8477           qd=ek(ix)
 8478 !---------ACphase input in radians
 8479           acphase=acdipph(ix)
 8480           nramp1=nturn2(ix)
 8481           nplato=nturn3(ix)
 8482           nramp2=nturn4(ix)
 8483           do j=1,napx
 8484       if (xory.eq.1) then
 8485         acdipamp2=acdipamp*tilts(i)
 8486         acdipamp1=acdipamp*tiltc(i)
 8487       else
 8488         acdipamp2=acdipamp*tiltc(i)
 8489         acdipamp1=-acdipamp*tilts(i)
 8490       endif
 8491               if(nramp1.gt.nac) then
 8492                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 8493      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 8494                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 8495      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 8496               endif
 8497               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 8498                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 8499      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 8500                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 8501      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 8502               endif
 8503               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 8504      &nac)then
 8505               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 8506      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 8507               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 8508      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 8509               endif
 8510       enddo
 8511       endif
 8512           goto 640
 8513   746     continue
 8514           xory=2
 8515           nfree=nturn1(ix)
 8516          if(n.gt.nfree) then
 8517           nac=n-nfree
 8518           pi=4d0*atan(1d0)
 8519 !---------ACdipAmp input in Tesla*meter converted to KeV/c
 8520 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
 8521           acdipamp=ed(ix)*clight*1.0d-3
 8522 !---------Qd input in tune units
 8523           qd=ek(ix)
 8524 !---------ACphase input in radians
 8525           acphase=acdipph(ix)
 8526           nramp1=nturn2(ix)
 8527           nplato=nturn3(ix)
 8528           nramp2=nturn4(ix)
 8529           do j=1,napx
 8530       if (xory.eq.1) then
 8531         acdipamp2=acdipamp*tilts(i)
 8532         acdipamp1=acdipamp*tiltc(i)
 8533       else
 8534         acdipamp2=acdipamp*tiltc(i)
 8535         acdipamp1=-acdipamp*tilts(i)
 8536       endif
 8537               if(nramp1.gt.nac) then
 8538                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 8539      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 8540                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 8541      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
 8542               endif
 8543               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
 8544                 yv(1,j)=yv(1,j)+acdipamp1*                              &
 8545      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 8546                 yv(2,j)=yv(2,j)+acdipamp2*                              &
 8547      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
 8548               endif
 8549               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
 8550      &nac)then
 8551               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
 8552      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 8553               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
 8554      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
 8555               endif
 8556       enddo
 8557       endif
 8558           goto 640
 8559  
 8560 !----------------------------
 8561  
 8562 ! Wire.
 8563  
 8564   748     continue
 8565 !     magnetic rigidity
 8566       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
 8567  
 8568       ix = ixcav
 8569       tx = xrms(ix)
 8570       ty = zrms(ix)
 8571       dx = xpl(ix)
 8572       dy = zpl(ix)
 8573       embl = ek(ix)
 8574       l = wirel(ix)
 8575       cur = ed(ix)
 8576  
 8577       leff = embl/cos(tx)/cos(ty)
 8578       rx = dx *cos(tx)-embl*sin(tx)/2
 8579       lin= dx *sin(tx)+embl*cos(tx)/2
 8580       ry = dy *cos(ty)-lin *sin(ty)
 8581       lin= lin*cos(ty)+dy  *sin(ty)
 8582  
 8583       do 750 j=1, napx
 8584  
 8585       xv(1,j) = xv(1,j) * c1m3
 8586       xv(2,j) = xv(2,j) * c1m3
 8587       yv(1,j) = yv(1,j) * c1m3
 8588       yv(2,j) = yv(2,j) * c1m3
 8589  
 8590 !      print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
 8591 !     &yv(2,j)
 8592  
 8593 !     call drift(-embl/2)
 8594  
 8595       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 8596      &yv(2,j)**2)
 8597       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 8598      &yv(2,j)**2)
 8599  
 8600 !     call tilt(tx,ty)
 8601  
 8602       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
 8603      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 8604      &yv(2,j)**2))-tx)
 8605       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
 8606      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
 8607       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 8608      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
 8609  
 8610       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
 8611      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 8612      &yv(2,j)**2))-ty)
 8613       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
 8614      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
 8615       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 8616      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
 8617  
 8618 !     call drift(lin)
 8619  
 8620       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 8621      &yv(2,j)**2)
 8622       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
 8623      &yv(2,j)**2)
 8624  
 8625 !      call kick(l,cur,lin,rx,ry,chi)
 8626  
 8627       xi = xv(1,j)-rx
 8628       yi = xv(2,j)-ry
 8629       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
 8630      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 8631      &xi**2+yi**2))
 8632 !GRD FOR CONSISTENSY
 8633 !      yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)*                  &
 8634       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
 8635      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
 8636      &xi**2+yi**2))
 8637  
 8638 !     call drift(leff-lin)
 8639  
 8640       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
 8641      &yv(1,j)**2-yv(2,j)**2)
 8642       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
 8643      &yv(1,j)**2-yv(2,j)**2)
 8644  
 8645 !     call invtilt(tx,ty)
 8646  
 8647       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
 8648      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 8649      &yv(2,j)**2))+ty)
 8650       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
 8651      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
 8652       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
 8653      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
 8654  
 8655       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
 8656      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
 8657      &yv(2,j)**2))+tx)
 8658       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
 8659      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
 8660       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
 8661      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
 8662  
 8663 !     call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
 8664  
 8665       xv(1,j) = xv(1,j) + embl*tan(tx)
 8666       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
 8667  
 8668 !     call drift(-embl/2)
 8669  
 8670       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 8671      &yv(2,j)**2)
 8672       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
 8673      &yv(2,j)**2)
 8674  
 8675       xv(1,j) = xv(1,j) * c1e3
 8676       xv(2,j) = xv(2,j) * c1e3
 8677       yv(1,j) = yv(1,j) * c1e3
 8678       yv(2,j) = yv(2,j) * c1e3
 8679  
 8680 !      print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
 8681 !     &yv(2,j)
 8682  
 8683 !-----------------------------------------------------------------------
 8684  
 8685   750     continue
 8686           goto 640
 8687  
 8688 !----------------------------
 8689  
 8690   640     continue
 8691           llost=.false.
 8692           do j=1,napx
 8693              llost=llost.or.                                            &
 8694      &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
 8695           enddo
 8696           if (llost) then
 8697              kpz=abs(kp(ix))
 8698              if(kpz.eq.2) then
 8699                 call lostpar3(i,ix,nthinerr)
 8700                 if(nthinerr.ne.0) return
 8701              elseif(kpz.eq.3) then
 8702                 call lostpar4(i,ix,nthinerr)
 8703                 if(nthinerr.ne.0) return
 8704              else
 8705                 call lostpar2(i,ix,nthinerr)
 8706                 if(nthinerr.ne.0) return
 8707              endif
 8708           endif
 8709   650   continue
 8710         call lostpart(nthinerr)
 8711         if(nthinerr.ne.0) return
 8712         if(ntwin.ne.2) call dist1
 8713         if(mod(n,nwr(4)).eq.0) call write6(n)
 8714   660 continue
 8715       return
 8716       end
 8717       subroutine ripple(n)
 8718 !-----------------------------------------------------------------------
 8719 !
 8720 !  F. SCHMIDT
 8721 !-----------------------------------------------------------------------
 8722       implicit none
 8723       integer i,n,nripple
 8724       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 8725      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 8726      &nrco,ntr,nzfz
 8727       parameter(npart = 64,nmac = 1)
 8728       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 8729      &nzfz = 300000,mmul = 11)
 8730       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 8731      &nema = 15)
 8732       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 8733       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 8734       parameter(nmon1 = 600,ncor1 = 600)
 8735       parameter(ntr = 20,nbb = 160)
 8736       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 8737      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 8738      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 8739      &one,pieni,pmae,pmap,three,two,zero
 8740       parameter(pieni = 1d-38)
 8741       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 8742       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 8743       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 8744       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 8745       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 8746      &1.0d16)
 8747       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 8748       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 8749       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 8750       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 8751       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 8752       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 8753       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 8754       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 8755       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 8756      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 8757      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 8758      &imc,imtr,iorg,iout,                                               &
 8759      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 8760      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 8761      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 8762      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 8763      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 8764      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 8765      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 8766      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 8767      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 8768       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 8769      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 8770      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 8771      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 8772      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 8773      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 8774      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 8775      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 8776      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 8777      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 8778      &acdipph
 8779       real hmal
 8780       character*16 bez,bezb,bezr,erbez,bezl
 8781       character*80 toptit,sixtit,commen
 8782       common/erro/ierro,erbez
 8783       common/kons/pi,pi2,pisqrt,rad
 8784       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 8785       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 8786       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 8787       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 8788       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 8789       common/syos2/rvf(mpa)
 8790       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 8791      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 8792       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 8793      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 8794      &iicav,itionc(nele),ition,idp,ncy,ixcav
 8795       common/corcom/dpscor,sigcor,icode,idam,its6d
 8796       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 8797      &bka(nele,mmul),aka(nele,mmul)
 8798       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 8799       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 8800       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 8801      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 8802       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 8803       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 8804      &iout
 8805       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 8806       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 8807      &ntco,eui,euii,nlin,bezl(nele)
 8808       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 8809      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 8810      &ncororb(nele)
 8811       common/apert/apx(nele),apz(nele),ape(3,nele)
 8812       common/clos/sigma0(2),iclo,ncorru,ncorrep
 8813       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 8814      &ratioe(nele),iratioe(nele),icoe
 8815       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 8816       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 8817       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 8818       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 8819       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 8820      &nstart,nstop,iskip,iconv,imad
 8821       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 8822       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 8823       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 8824       common/ripp2/nrturn
 8825       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 8826       common/pawc/hmal(nplo)
 8827       common/tit/sixtit,commen,ithick
 8828       common/co6d/clo6(3),clop6(3)
 8829       common/dkic/dki(nele,3)
 8830       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 8831      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 8832      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 8833      &nbeam,ibbc,ibeco,ibtyp,lhc
 8834       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 8835       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 8836       common/wireco/ wirel(nele)
 8837       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 8838      &nturn3(nele), nturn4(nele)
 8839       integer idz,itra
 8840       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 8841       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 8842      &dps(mpa),idz(2)
 8843       common/anf/chi0,chid,exz(2,6),dp1,itra
 8844       integer ichrom,is
 8845       double precision alf0,amp,bet0,clo,clop,cro,x,y
 8846       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 8847       common/chrom/cro(2),is(2),ichrom
 8848       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 8849      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 8850       double precision dpmax,preda,weig1,weig2
 8851       character*16 coel
 8852       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 8853       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 8854       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 8855      &coel(10)
 8856       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 8857      &zsi
 8858       real tlim,time0,time1
 8859       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 8860      &aai(nblz,mmul),bbi(nblz,mmul)
 8861       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 8862       common/damp/damp,ampt
 8863       common/ttime/tlim,time0,time1
 8864       double precision tasm
 8865       common/tasm/tasm(6,6)
 8866       integer iv,ixv,nlostp,nms,numxv
 8867       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 8868      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 8869      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 8870      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 8871      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 8872      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 8873      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 8874      &zsiv,zsv
 8875       logical pstop
 8876       common/main1/                                                     &
 8877      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 8878      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 8879      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 8880      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 8881      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 8882      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 8883      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 8884      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 8885       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 8886      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 8887      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 8888      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 8889      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 8890      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 8891      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 8892      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 8893      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 8894       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 8895      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 8896      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 8897      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 8898       integer numx
 8899       double precision e0f
 8900       common/main4/ e0f,numx
 8901       integer ktrack,nwri
 8902       double precision dpsv1,strack,strackc,stracks
 8903       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 8904      &stracks(nblz),dpsv1(npart),nwri
 8905       save
 8906 !-----------------------------------------------------------------------
 8907       nripple=nrturn+n
 8908       do 20 i=1,iu
 8909         if(abs(rsmi(i)).gt.pieni) then
 8910           smiv(1,i)=rsmi(i)*cos(two*pi*(nripple-1)/rfres(i)+rzphs(i))
 8911         strack(i)=smiv(1,i)
 8912         strackc(i)=strack(i)*tiltc(i)
 8913         stracks(i)=strack(i)*tilts(i)
 8914         endif
 8915    20 continue
 8916       return
 8917       end
 8918       subroutine writebin(nthinerr)
 8919 !-----------------------------------------------------------------------
 8920 !
 8921 !  F. SCHMIDT
 8922 !-----------------------------------------------------------------------
 8923 !  3 February 1999
 8924 !-----------------------------------------------------------------------
 8925       implicit none
 8926       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 8927      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 8928      &nrco,ntr,nzfz
 8929       parameter(npart = 64,nmac = 1)
 8930       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 8931      &nzfz = 300000,mmul = 11)
 8932       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 8933      &nema = 15)
 8934       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 8935       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 8936       parameter(nmon1 = 600,ncor1 = 600)
 8937       parameter(ntr = 20,nbb = 160)
 8938       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 8939      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 8940      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 8941      &one,pieni,pmae,pmap,three,two,zero
 8942       parameter(pieni = 1d-38)
 8943       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 8944       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 8945       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 8946       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 8947       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 8948      &1.0d16)
 8949       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 8950       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 8951       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 8952       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 8953       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 8954       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 8955       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 8956       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 8957       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 8958      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 8959      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 8960      &imc,imtr,iorg,iout,                                               &
 8961      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 8962      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 8963      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 8964      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 8965      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 8966      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 8967      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 8968      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 8969      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 8970       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 8971      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 8972      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 8973      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 8974      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 8975      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 8976      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 8977      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 8978      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 8979      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 8980      &acdipph
 8981       real hmal
 8982       character*16 bez,bezb,bezr,erbez,bezl
 8983       character*80 toptit,sixtit,commen
 8984       common/erro/ierro,erbez
 8985       common/kons/pi,pi2,pisqrt,rad
 8986       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 8987       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 8988       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 8989       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 8990       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 8991       common/syos2/rvf(mpa)
 8992       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 8993      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 8994       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 8995      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 8996      &iicav,itionc(nele),ition,idp,ncy,ixcav
 8997       common/corcom/dpscor,sigcor,icode,idam,its6d
 8998       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 8999      &bka(nele,mmul),aka(nele,mmul)
 9000       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 9001       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 9002       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 9003      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 9004       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 9005       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 9006      &iout
 9007       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 9008       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 9009      &ntco,eui,euii,nlin,bezl(nele)
 9010       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 9011      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 9012      &ncororb(nele)
 9013       common/apert/apx(nele),apz(nele),ape(3,nele)
 9014       common/clos/sigma0(2),iclo,ncorru,ncorrep
 9015       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 9016      &ratioe(nele),iratioe(nele),icoe
 9017       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 9018       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 9019       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 9020       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 9021       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 9022      &nstart,nstop,iskip,iconv,imad
 9023       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 9024       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 9025       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 9026       common/ripp2/nrturn
 9027       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 9028       common/pawc/hmal(nplo)
 9029       common/tit/sixtit,commen,ithick
 9030       common/co6d/clo6(3),clop6(3)
 9031       common/dkic/dki(nele,3)
 9032       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 9033      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 9034      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 9035      &nbeam,ibbc,ibeco,ibtyp,lhc
 9036       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 9037       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 9038       common/wireco/ wirel(nele)
 9039       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 9040      &nturn3(nele), nturn4(nele)
 9041       integer idz,itra
 9042       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 9043       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 9044      &dps(mpa),idz(2)
 9045       common/anf/chi0,chid,exz(2,6),dp1,itra
 9046       integer ichrom,is
 9047       double precision alf0,amp,bet0,clo,clop,cro,x,y
 9048       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 9049       common/chrom/cro(2),is(2),ichrom
 9050       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 9051      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 9052       double precision dpmax,preda,weig1,weig2
 9053       character*16 coel
 9054       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 9055       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 9056       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 9057      &coel(10)
 9058       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 9059      &zsi
 9060       real tlim,time0,time1
 9061       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 9062      &aai(nblz,mmul),bbi(nblz,mmul)
 9063       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 9064       common/damp/damp,ampt
 9065       common/ttime/tlim,time0,time1
 9066       double precision tasm
 9067       common/tasm/tasm(6,6)
 9068       integer iv,ixv,nlostp,nms,numxv
 9069       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 9070      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 9071      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 9072      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 9073      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 9074      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 9075      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 9076      &zsiv,zsv
 9077       logical pstop
 9078       common/main1/                                                     &
 9079      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 9080      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 9081      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 9082      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 9083      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 9084      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 9085      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 9086      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 9087       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 9088      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 9089      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 9090      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 9091      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 9092      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 9093      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 9094      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 9095      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 9096       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 9097      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 9098      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 9099      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 9100       integer numx
 9101       double precision e0f
 9102       common/main4/ e0f,numx
 9103       integer ktrack,nwri
 9104       double precision dpsv1,strack,strackc,stracks
 9105       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 9106      &stracks(nblz),dpsv1(npart),nwri
 9107       integer ia,ia2,ie,nthinerr
 9108       save
 9109 !-----------------------------------------------------------------------
 9110 !GRD      do 10 ia=1,napx
 9111       do 10 ia=1,napx-1
 9112 !GRD
 9113         if(.not.pstop(nlostp(ia)).and..not.pstop(nlostp(ia)+1).and.     &
 9114      &(mod(nlostp(ia),2).ne.0)) then
 9115           ia2=(nlostp(ia)+1)/2
 9116           ie=ia+1
 9117           if(ntwin.ne.2) then
 9118             write(91-ia2,iostat=ierro)                                  &
 9119      &numx,nlostp(ia),dam(ia),                                          &
 9120      &xv(1,ia),yv(1,ia),xv(2,ia),yv(2,ia),sigmv(ia),dpsv(ia),e0
 9121             endfile 91-ia2
 9122             backspace 91-ia2
 9123           else
 9124             write(91-ia2,iostat=ierro)                                  &
 9125      &numx,nlostp(ia),dam(ia),                                          &
 9126      &xv(1,ia),yv(1,ia),xv(2,ia),yv(2,ia),sigmv(ia),dpsv(ia),e0,        &
 9127      &nlostp(ia)+1,dam(ia),                                             &
 9128      &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie),e0
 9129             endfile 91-ia2
 9130             backspace 91-ia2
 9131           endif
 9132           if(ierro.ne.0) then
 9133             write(*,*)
 9134             write(*,*) '*** ERROR ***,PROBLEMS WRITING TO FILE # : ',   &
 9135      &91-ia2
 9136             write(*,*) 'ERROR CODE : ',ierro
 9137             write(*,*)
 9138             endfile 12
 9139             backspace 12
 9140             nthinerr=3000
 9141             return
 9142           endif
 9143         endif
 9144    10 continue
 9145       return
 9146       end
 9147       subroutine lostpart(nthinerr)
 9148 !-----------------------------------------------------------------------
 9149 !
 9150 !  F. SCHMIDT
 9151 !-----------------------------------------------------------------------
 9152 !  3 February 1999
 9153 !-----------------------------------------------------------------------
 9154       implicit none
 9155 !      logical isnan
 9156       logical myisnan
 9157       integer ib2,ib3,ilostch,j,jj,jj1,lnapx,nthinerr
 9158       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 9159      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 9160      &nrco,ntr,nzfz
 9161       parameter(npart = 64,nmac = 1)
 9162       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 9163      &nzfz = 300000,mmul = 11)
 9164       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 9165      &nema = 15)
 9166       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 9167       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 9168       parameter(nmon1 = 600,ncor1 = 600)
 9169       parameter(ntr = 20,nbb = 160)
 9170       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 9171      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 9172      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 9173      &one,pieni,pmae,pmap,three,two,zero
 9174       parameter(pieni = 1d-38)
 9175       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 9176       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 9177       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 9178       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 9179       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 9180      &1.0d16)
 9181       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 9182       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 9183       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 9184       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 9185       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 9186       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 9187       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 9188       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 9189       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 9190      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 9191      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 9192      &imc,imtr,iorg,iout,                                               &
 9193      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 9194      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 9195      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 9196      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 9197      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 9198      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 9199      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 9200      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 9201      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 9202       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 9203      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 9204      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 9205      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 9206      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 9207      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 9208      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 9209      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 9210      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 9211      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 9212      &acdipph
 9213       real hmal
 9214       character*16 bez,bezb,bezr,erbez,bezl
 9215       character*80 toptit,sixtit,commen
 9216       common/erro/ierro,erbez
 9217       common/kons/pi,pi2,pisqrt,rad
 9218       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 9219       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 9220       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 9221       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 9222       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 9223       common/syos2/rvf(mpa)
 9224       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 9225      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 9226       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 9227      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 9228      &iicav,itionc(nele),ition,idp,ncy,ixcav
 9229       common/corcom/dpscor,sigcor,icode,idam,its6d
 9230       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 9231      &bka(nele,mmul),aka(nele,mmul)
 9232       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 9233       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 9234       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 9235      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 9236       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 9237       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 9238      &iout
 9239       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 9240       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 9241      &ntco,eui,euii,nlin,bezl(nele)
 9242       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 9243      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 9244      &ncororb(nele)
 9245       common/apert/apx(nele),apz(nele),ape(3,nele)
 9246       common/clos/sigma0(2),iclo,ncorru,ncorrep
 9247       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 9248      &ratioe(nele),iratioe(nele),icoe
 9249       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 9250       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 9251       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 9252       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 9253       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 9254      &nstart,nstop,iskip,iconv,imad
 9255       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 9256       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 9257       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 9258       common/ripp2/nrturn
 9259       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 9260       common/pawc/hmal(nplo)
 9261       common/tit/sixtit,commen,ithick
 9262       common/co6d/clo6(3),clop6(3)
 9263       common/dkic/dki(nele,3)
 9264       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 9265      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 9266      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 9267      &nbeam,ibbc,ibeco,ibtyp,lhc
 9268       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 9269       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 9270       common/wireco/ wirel(nele)
 9271       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 9272      &nturn3(nele), nturn4(nele)
 9273       integer nnumxv
 9274       common/postr2/nnumxv(npart)
 9275       integer idz,itra
 9276       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 9277       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 9278      &dps(mpa),idz(2)
 9279       common/anf/chi0,chid,exz(2,6),dp1,itra
 9280       integer ichrom,is
 9281       double precision alf0,amp,bet0,clo,clop,cro,x,y
 9282       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 9283       common/chrom/cro(2),is(2),ichrom
 9284       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 9285      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 9286       double precision dpmax,preda,weig1,weig2
 9287       character*16 coel
 9288       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 9289       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 9290       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 9291      &coel(10)
 9292       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 9293      &zsi
 9294       real tlim,time0,time1
 9295       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 9296      &aai(nblz,mmul),bbi(nblz,mmul)
 9297       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 9298       common/damp/damp,ampt
 9299       common/ttime/tlim,time0,time1
 9300       double precision tasm
 9301       common/tasm/tasm(6,6)
 9302       integer iv,ixv,nlostp,nms,numxv
 9303       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 9304      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 9305      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 9306      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 9307      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 9308      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 9309      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 9310      &zsiv,zsv
 9311       logical pstop
 9312       common/main1/                                                     &
 9313      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 9314      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 9315      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 9316      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 9317      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 9318      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 9319      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 9320      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 9321       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 9322      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 9323      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 9324      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 9325      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 9326      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 9327      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 9328      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 9329      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 9330       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 9331      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 9332      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 9333      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 9334       integer numx
 9335       double precision e0f
 9336       common/main4/ e0f,numx
 9337       integer ktrack,nwri
 9338       double precision dpsv1,strack,strackc,stracks
 9339       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 9340      &stracks(nblz),dpsv1(npart),nwri
 9341       save
 9342 !-----------------------------------------------------------------------
 9343       ilostch=0
 9344       do 10 j=1,napx
 9345         if(abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2).or.       &
 9346 !     &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
 9347      &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
 9348           ilostch=1
 9349           pstop(nlostp(j))=.true.
 9350         endif
 9351   10  continue
 9352       do 20 j=1,napx
 9353         if(pstop(nlostp(j))) then
 9354           aperv(nlostp(j),1)=aper(1)
 9355           aperv(nlostp(j),2)=aper(2)
 9356           xvl(1,nlostp(j))=xv(1,j)
 9357           xvl(2,nlostp(j))=xv(2,j)
 9358           yvl(1,nlostp(j))=yv(1,j)
 9359           yvl(2,nlostp(j))=yv(2,j)
 9360           dpsvl(nlostp(j))=dpsv(j)
 9361           ejvl(nlostp(j))=ejv(j)
 9362           sigmvl(nlostp(j))=sigmv(j)
 9363           numxv(nlostp(j))=numx
 9364           nnumxv(nlostp(j))=numx
 9365           if(mod(nlostp(j),2).eq.one) then
 9366             write(*,10000) nlostp(j),nms(nlostp(j))*izu0,               &
 9367      &dp0v(nlostp(j)),numxv(nlostp(j)),abs(xvl(1,nlostp(j))),           &
 9368      &aperv(nlostp(j),1),abs(xvl(2,nlostp(j))),                         &
 9369      &aperv(nlostp(j),2)
 9370           else
 9371             write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0,             &
 9372      &dp0v(nlostp(j)-1),numxv(nlostp(j)),abs(xvl(1,nlostp(j))),         &
 9373      &aperv(nlostp(j),1),abs(xvl(2,nlostp(j))),                         &
 9374      &aperv(nlostp(j),2)
 9375           endif
 9376         endif
 9377    20 continue
 9378       lnapx=napx
 9379       do 30 j=napx,1,-1
 9380         if(pstop(nlostp(j))) then
 9381           if(j.ne.lnapx) then
 9382             do 35 jj=j,lnapx-1
 9383               jj1=jj+1
 9384               nlostp(jj)=nlostp(jj1)
 9385               xv(1,jj)=xv(1,jj1)
 9386               xv(2,jj)=xv(2,jj1)
 9387               yv(1,jj)=yv(1,jj1)
 9388               yv(2,jj)=yv(2,jj1)
 9389               dpsv(jj)=dpsv(jj1)
 9390               sigmv(jj)=sigmv(jj1)
 9391               ejfv(jj)=ejfv(jj1)
 9392               ejv(jj)=ejv(jj1)
 9393               rvv(jj)=rvv(jj1)
 9394               oidpsv(jj)=oidpsv(jj1)
 9395               dpsv1(jj)=dpsv1(jj1)
 9396               clo6v(1,jj)=clo6v(1,jj1)
 9397               clo6v(2,jj)=clo6v(2,jj1)
 9398               clo6v(3,jj)=clo6v(3,jj1)
 9399               clop6v(1,jj)=clop6v(1,jj1)
 9400               clop6v(2,jj)=clop6v(2,jj1)
 9401               clop6v(3,jj)=clop6v(3,jj1)
 9402 !--beam-beam element
 9403               di0xs(jj)=di0xs(jj1)
 9404               dip0xs(jj)=dip0xs(jj1)
 9405               di0zs(jj)=di0zs(jj1)
 9406               dip0zs(jj)=dip0zs(jj1)
 9407               do 210 ib2=1,6
 9408                 do 210 ib3=1,6
 9409                   tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
 9410   210         continue
 9411    35       continue
 9412           endif
 9413           lnapx=lnapx-1
 9414         endif
 9415    30 continue
 9416       if(lnapx.eq.0) then
 9417         write(*,*)
 9418         write(*,*)
 9419         write(*,*) '***********************'
 9420         write(*,*) '** ALL PARTICLE LOST **'
 9421         write(*,*) '**   PROGRAM STOPS   **'
 9422         write(*,*) '***********************'
 9423         write(*,*)
 9424         write(*,*)
 9425         nthinerr=3001
 9426         return
 9427       endif
 9428       if(ithick.eq.1.and.ilostch.eq.1)                                  &
 9429      &call synuthck
 9430       napx=lnapx
 9431       return
 9432 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3,       &
 9433      &' RANDOM SEED ',i8,/ t10,' MOMENTUM DEVIATION ',g12.5,            &
 9434      &' LOST IN REVOLUTION ',i8,/ t10,'HORIZ:  AMPLITUDE = ',f15.3,     &
 9435      &'   APERTURE = ',f15.3/ t10,'VERT:   AMPLITUDE = ',f15.3,         &
 9436      &'   APERTURE = ',f15.3/)
 9437       end
 9438       subroutine lostpar2(i,ix,nthinerr)
 9439 !-----------------------------------------------------------------------
 9440 !
 9441 !  F. SCHMIDT
 9442 !-----------------------------------------------------------------------
 9443 !  3 February 1999
 9444 !-----------------------------------------------------------------------
 9445       implicit none
 9446 !      logical isnan
 9447       logical myisnan
 9448       integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
 9449       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 9450      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 9451      &nrco,ntr,nzfz
 9452       parameter(npart = 64,nmac = 1)
 9453       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 9454      &nzfz = 300000,mmul = 11)
 9455       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 9456      &nema = 15)
 9457       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 9458       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 9459       parameter(nmon1 = 600,ncor1 = 600)
 9460       parameter(ntr = 20,nbb = 160)
 9461       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 9462      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 9463      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 9464      &one,pieni,pmae,pmap,three,two,zero
 9465       parameter(pieni = 1d-38)
 9466       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 9467       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 9468       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 9469       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 9470       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 9471      &1.0d16)
 9472       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 9473       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 9474       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 9475       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 9476       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 9477       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 9478       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 9479       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 9480       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 9481      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 9482      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 9483      &imc,imtr,iorg,iout,                                               &
 9484      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 9485      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 9486      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 9487      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 9488      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 9489      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 9490      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 9491      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 9492      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 9493       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 9494      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 9495      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 9496      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 9497      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 9498      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 9499      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 9500      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 9501      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 9502      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 9503      &acdipph
 9504       real hmal
 9505       character*16 bez,bezb,bezr,erbez,bezl
 9506       character*80 toptit,sixtit,commen
 9507       common/erro/ierro,erbez
 9508       common/kons/pi,pi2,pisqrt,rad
 9509       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 9510       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 9511       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 9512       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 9513       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 9514       common/syos2/rvf(mpa)
 9515       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 9516      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 9517       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 9518      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 9519      &iicav,itionc(nele),ition,idp,ncy,ixcav
 9520       common/corcom/dpscor,sigcor,icode,idam,its6d
 9521       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 9522      &bka(nele,mmul),aka(nele,mmul)
 9523       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 9524       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 9525       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 9526      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 9527       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 9528       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 9529      &iout
 9530       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 9531       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 9532      &ntco,eui,euii,nlin,bezl(nele)
 9533       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 9534      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 9535      &ncororb(nele)
 9536       common/apert/apx(nele),apz(nele),ape(3,nele)
 9537       common/clos/sigma0(2),iclo,ncorru,ncorrep
 9538       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 9539      &ratioe(nele),iratioe(nele),icoe
 9540       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 9541       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 9542       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 9543       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 9544       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 9545      &nstart,nstop,iskip,iconv,imad
 9546       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 9547       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 9548       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 9549       common/ripp2/nrturn
 9550       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 9551       common/pawc/hmal(nplo)
 9552       common/tit/sixtit,commen,ithick
 9553       common/co6d/clo6(3),clop6(3)
 9554       common/dkic/dki(nele,3)
 9555       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 9556      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 9557      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 9558      &nbeam,ibbc,ibeco,ibtyp,lhc
 9559       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 9560       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 9561       common/wireco/ wirel(nele)
 9562       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 9563      &nturn3(nele), nturn4(nele)
 9564       integer nnumxv
 9565       common/postr2/nnumxv(npart)
 9566       integer idz,itra
 9567       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 9568       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 9569      &dps(mpa),idz(2)
 9570       common/anf/chi0,chid,exz(2,6),dp1,itra
 9571       integer ichrom,is
 9572       double precision alf0,amp,bet0,clo,clop,cro,x,y
 9573       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 9574       common/chrom/cro(2),is(2),ichrom
 9575       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 9576      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 9577       double precision dpmax,preda,weig1,weig2
 9578       character*16 coel
 9579       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 9580       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 9581       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 9582      &coel(10)
 9583       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 9584      &zsi
 9585       real tlim,time0,time1
 9586       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 9587      &aai(nblz,mmul),bbi(nblz,mmul)
 9588       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 9589       common/damp/damp,ampt
 9590       common/ttime/tlim,time0,time1
 9591       double precision tasm
 9592       common/tasm/tasm(6,6)
 9593       integer iv,ixv,nlostp,nms,numxv
 9594       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 9595      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 9596      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 9597      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 9598      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 9599      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 9600      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 9601      &zsiv,zsv
 9602       logical pstop
 9603       common/main1/                                                     &
 9604      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 9605      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 9606      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 9607      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 9608      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 9609      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 9610      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 9611      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 9612       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 9613      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 9614      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 9615      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 9616      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 9617      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 9618      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 9619      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 9620      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 9621       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 9622      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 9623      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 9624      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 9625       integer numx
 9626       double precision e0f
 9627       common/main4/ e0f,numx
 9628       integer ktrack,nwri
 9629       double precision dpsv1,strack,strackc,stracks
 9630       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 9631      &stracks(nblz),dpsv1(npart),nwri
 9632       save
 9633 !-----------------------------------------------------------------------
 9634       ilostch=0
 9635       do 10 j=1,napx
 9636         if(abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2).or.       &
 9637 !     &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
 9638      &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
 9639           ilostch=1
 9640           pstop(nlostp(j))=.true.
 9641         endif
 9642   10  continue
 9643       do 20 j=1,napx
 9644         if(pstop(nlostp(j))) then
 9645           aperv(nlostp(j),1)=aper(1)
 9646           aperv(nlostp(j),2)=aper(2)
 9647           iv(nlostp(j))=i
 9648           ixv(nlostp(j))=ix
 9649           xvl(1,nlostp(j))=xv(1,j)
 9650           xvl(2,nlostp(j))=xv(2,j)
 9651           yvl(1,nlostp(j))=yv(1,j)
 9652           yvl(2,nlostp(j))=yv(2,j)
 9653           dpsvl(nlostp(j))=dpsv(j)
 9654           ejvl(nlostp(j))=ejv(j)
 9655           sigmvl(nlostp(j))=sigmv(j)
 9656           numxv(nlostp(j))=numx
 9657           nnumxv(nlostp(j))=numx
 9658           if(mod(nlostp(j),2).eq.one) then
 9659             write(*,10000) nlostp(j),nms(nlostp(j))*izu0,               &
 9660      &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)),                   &
 9661      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
 9662      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
 9663      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
 9664           else
 9665             write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0,             &
 9666      &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)),                 &
 9667      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
 9668      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
 9669      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
 9670           endif
 9671         endif
 9672    20 continue
 9673       lnapx=napx
 9674       do 30 j=napx,1,-1
 9675         if(pstop(nlostp(j))) then
 9676           if(j.ne.lnapx) then
 9677             do 35 jj=j,lnapx-1
 9678               jj1=jj+1
 9679               nlostp(jj)=nlostp(jj1)
 9680               xv(1,jj)=xv(1,jj1)
 9681               xv(2,jj)=xv(2,jj1)
 9682               yv(1,jj)=yv(1,jj1)
 9683               yv(2,jj)=yv(2,jj1)
 9684               dpsv(jj)=dpsv(jj1)
 9685               sigmv(jj)=sigmv(jj1)
 9686               ejfv(jj)=ejfv(jj1)
 9687               ejv(jj)=ejv(jj1)
 9688               rvv(jj)=rvv(jj1)
 9689               oidpsv(jj)=oidpsv(jj1)
 9690               dpsv1(jj)=dpsv1(jj1)
 9691               clo6v(1,jj)=clo6v(1,jj1)
 9692               clo6v(2,jj)=clo6v(2,jj1)
 9693               clo6v(3,jj)=clo6v(3,jj1)
 9694               clop6v(1,jj)=clop6v(1,jj1)
 9695               clop6v(2,jj)=clop6v(2,jj1)
 9696               clop6v(3,jj)=clop6v(3,jj1)
 9697 !--beam-beam element
 9698               di0xs(jj)=di0xs(jj1)
 9699               dip0xs(jj)=dip0xs(jj1)
 9700               di0zs(jj)=di0zs(jj1)
 9701               dip0zs(jj)=dip0zs(jj1)
 9702               do 210 ib2=1,6
 9703                 do 210 ib3=1,6
 9704                   tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
 9705   210         continue
 9706    35       continue
 9707           endif
 9708           lnapx=lnapx-1
 9709         endif
 9710    30 continue
 9711       if(lnapx.eq.0) then
 9712         write(*,*)
 9713         write(*,*)
 9714         write(*,*) '***********************'
 9715         write(*,*) '** ALL PARTICLE LOST **'
 9716         write(*,*) '**   PROGRAM STOPS   **'
 9717         write(*,*) '***********************'
 9718         write(*,*)
 9719         write(*,*)
 9720         nthinerr=3001
 9721         return
 9722       endif
 9723       if(ithick.eq.1.and.ilostch.eq.1)                                  &
 9724      &call synuthck
 9725       napx=lnapx
 9726       return
 9727 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3,       &
 9728      &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10,            &
 9729      &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10,                 &
 9730      &'HORIZ:  AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10,         &
 9731      &'VERT:   AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10,         &
 9732      &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
 9733       end
 9734       subroutine lostpar3(i,ix,nthinerr)
 9735 !-----------------------------------------------------------------------
 9736 !
 9737 !  F. SCHMIDT
 9738 !-----------------------------------------------------------------------
 9739 !  3 February 1999
 9740 !-----------------------------------------------------------------------
 9741       implicit none
 9742 !      logical isnan
 9743       logical myisnan
 9744       integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
 9745       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
 9746      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
 9747      &nrco,ntr,nzfz
 9748       parameter(npart = 64,nmac = 1)
 9749       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
 9750      &nzfz = 300000,mmul = 11)
 9751       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
 9752      &nema = 15)
 9753       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
 9754       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
 9755       parameter(nmon1 = 600,ncor1 = 600)
 9756       parameter(ntr = 20,nbb = 160)
 9757       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
 9758      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
 9759      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
 9760      &one,pieni,pmae,pmap,three,two,zero
 9761       parameter(pieni = 1d-38)
 9762       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
 9763       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
 9764       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
 9765       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
 9766       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
 9767      &1.0d16)
 9768       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
 9769       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
 9770       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
 9771       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
 9772       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
 9773       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
 9774       parameter(pmap = 938.271998d0,pmae = .510998902d0)
 9775       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
 9776       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
 9777      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
 9778      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
 9779      &imc,imtr,iorg,iout,                                               &
 9780      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
 9781      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
 9782      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
 9783      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
 9784      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
 9785      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
 9786      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
 9787      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
 9788      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
 9789       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
 9790      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
 9791      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
 9792      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
 9793      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
 9794      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
 9795      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
 9796      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
 9797      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
 9798      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
 9799      &acdipph
 9800       real hmal
 9801       character*16 bez,bezb,bezr,erbez,bezl
 9802       character*80 toptit,sixtit,commen
 9803       common/erro/ierro,erbez
 9804       common/kons/pi,pi2,pisqrt,rad
 9805       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
 9806       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
 9807       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
 9808       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
 9809       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
 9810       common/syos2/rvf(mpa)
 9811       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
 9812      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
 9813       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
 9814      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
 9815      &iicav,itionc(nele),ition,idp,ncy,ixcav
 9816       common/corcom/dpscor,sigcor,icode,idam,its6d
 9817       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
 9818      &bka(nele,mmul),aka(nele,mmul)
 9819       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
 9820       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
 9821       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
 9822      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
 9823       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
 9824       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
 9825      &iout
 9826       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
 9827       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
 9828      &ntco,eui,euii,nlin,bezl(nele)
 9829       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
 9830      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
 9831      &ncororb(nele)
 9832       common/apert/apx(nele),apz(nele),ape(3,nele)
 9833       common/clos/sigma0(2),iclo,ncorru,ncorrep
 9834       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
 9835      &ratioe(nele),iratioe(nele),icoe
 9836       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
 9837       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
 9838       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
 9839       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
 9840       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
 9841      &nstart,nstop,iskip,iconv,imad
 9842       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
 9843       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
 9844       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
 9845       common/ripp2/nrturn
 9846       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
 9847       common/pawc/hmal(nplo)
 9848       common/tit/sixtit,commen,ithick
 9849       common/co6d/clo6(3),clop6(3)
 9850       common/dkic/dki(nele,3)
 9851       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
 9852      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
 9853      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
 9854      &nbeam,ibbc,ibeco,ibtyp,lhc
 9855       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
 9856       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
 9857       common/wireco/ wirel(nele)
 9858       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
 9859      &nturn3(nele), nturn4(nele)
 9860       integer nnumxv
 9861       common/postr2/nnumxv(npart)
 9862       integer idz,itra
 9863       double precision al,as,chi0,chid,dp1,dps,exz,sigm
 9864       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
 9865      &dps(mpa),idz(2)
 9866       common/anf/chi0,chid,exz(2,6),dp1,itra
 9867       integer ichrom,is
 9868       double precision alf0,amp,bet0,clo,clop,cro,x,y
 9869       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
 9870       common/chrom/cro(2),is(2),ichrom
 9871       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
 9872      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
 9873       double precision dpmax,preda,weig1,weig2
 9874       character*16 coel
 9875       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
 9876       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
 9877       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
 9878      &coel(10)
 9879       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
 9880      &zsi
 9881       real tlim,time0,time1
 9882       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
 9883      &aai(nblz,mmul),bbi(nblz,mmul)
 9884       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
 9885       common/damp/damp,ampt
 9886       common/ttime/tlim,time0,time1
 9887       double precision tasm
 9888       common/tasm/tasm(6,6)
 9889       integer iv,ixv,nlostp,nms,numxv
 9890       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
 9891      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
 9892      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
 9893      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
 9894      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
 9895      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
 9896      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
 9897      &zsiv,zsv
 9898       logical pstop
 9899       common/main1/                                                     &
 9900      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
 9901      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
 9902      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
 9903      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
 9904      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
 9905      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
 9906      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
 9907      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
 9908       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
 9909      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
 9910      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
 9911      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
 9912      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
 9913      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
 9914      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
 9915      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
 9916      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
 9917       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
 9918      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
 9919      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
 9920      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
 9921       integer numx
 9922       double precision e0f
 9923       common/main4/ e0f,numx
 9924       integer ktrack,nwri
 9925       double precision dpsv1,strack,strackc,stracks
 9926       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
 9927      &stracks(nblz),dpsv1(npart),nwri
 9928       save
 9929 !-----------------------------------------------------------------------
 9930       ilostch=0
 9931       do 10 j=1,napx
 9932         if(abs(xv(1,j)).gt.apx(ix).or.abs(xv(2,j)).gt.apz(ix).or.       &
 9933 !     &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
 9934      &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
 9935           ilostch=1
 9936           pstop(nlostp(j))=.true.
 9937         endif
 9938   10  continue
 9939       do 20 j=1,napx
 9940         if(pstop(nlostp(j))) then
 9941           aperv(nlostp(j),1)=apx(ix)
 9942           aperv(nlostp(j),2)=apz(ix)
 9943           iv(nlostp(j))=i
 9944           ixv(nlostp(j))=ix
 9945           xvl(1,nlostp(j))=xv(1,j)
 9946           xvl(2,nlostp(j))=xv(2,j)
 9947           yvl(1,nlostp(j))=yv(1,j)
 9948           yvl(2,nlostp(j))=yv(2,j)
 9949           dpsvl(nlostp(j))=dpsv(j)
 9950           ejvl(nlostp(j))=ejv(j)
 9951           sigmvl(nlostp(j))=sigmv(j)
 9952           numxv(nlostp(j))=numx
 9953           nnumxv(nlostp(j))=numx
 9954           if(mod(nlostp(j),2).eq.one) then
 9955             write(*,10000) nlostp(j),nms(nlostp(j))*izu0,               &
 9956      &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)),                   &
 9957      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
 9958      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
 9959      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
 9960           else
 9961             write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0,             &
 9962      &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)),                 &
 9963      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
 9964      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
 9965      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
 9966           endif
 9967         endif
 9968    20 continue
 9969       lnapx=napx
 9970       do 30 j=napx,1,-1
 9971         if(pstop(nlostp(j))) then
 9972           if(j.ne.lnapx) then
 9973             do 35 jj=j,lnapx-1
 9974               jj1=jj+1
 9975               nlostp(jj)=nlostp(jj1)
 9976               xv(1,jj)=xv(1,jj1)
 9977               xv(2,jj)=xv(2,jj1)
 9978               yv(1,jj)=yv(1,jj1)
 9979               yv(2,jj)=yv(2,jj1)
 9980               dpsv(jj)=dpsv(jj1)
 9981               sigmv(jj)=sigmv(jj1)
 9982               ejfv(jj)=ejfv(jj1)
 9983               ejv(jj)=ejv(jj1)
 9984               rvv(jj)=rvv(jj1)
 9985               oidpsv(jj)=oidpsv(jj1)
 9986               dpsv1(jj)=dpsv1(jj1)
 9987               clo6v(1,jj)=clo6v(1,jj1)
 9988               clo6v(2,jj)=clo6v(2,jj1)
 9989               clo6v(3,jj)=clo6v(3,jj1)
 9990               clop6v(1,jj)=clop6v(1,jj1)
 9991               clop6v(2,jj)=clop6v(2,jj1)
 9992               clop6v(3,jj)=clop6v(3,jj1)
 9993 !--beam-beam element
 9994               di0xs(jj)=di0xs(jj1)
 9995               dip0xs(jj)=dip0xs(jj1)
 9996               di0zs(jj)=di0zs(jj1)
 9997               dip0zs(jj)=dip0zs(jj1)
 9998               do 210 ib2=1,6
 9999                 do 210 ib3=1,6
10000                   tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
10001   210         continue
10002    35       continue
10003           endif
10004           lnapx=lnapx-1
10005         endif
10006    30 continue
10007       if(lnapx.eq.0) then
10008         write(*,*)
10009         write(*,*)
10010         write(*,*) '***********************'
10011         write(*,*) '** ALL PARTICLE LOST **'
10012         write(*,*) '**   PROGRAM STOPS   **'
10013         write(*,*) '***********************'
10014         write(*,*)
10015         write(*,*)
10016         nthinerr=3001
10017         return
10018       endif
10019       if(ithick.eq.1.and.ilostch.eq.1)                                  &
10020      &call synuthck
10021       napx=lnapx
10022       return
10023 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3,       &
10024      &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10,            &
10025      &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10,                 &
10026      &'HORIZ:  AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10,         &
10027      &'VERT:   AMPLITUDE = ',f15.3,'RE-APERTURE = ',f15.3/ t10,         &
10028      &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
10029       end
10030       subroutine lostpar4(i,ix,nthinerr)
10031 !-----------------------------------------------------------------------
10032 !
10033 !  F. SCHMIDT
10034 !-----------------------------------------------------------------------
10035 !  3 February 1999
10036 !-----------------------------------------------------------------------
10037       implicit none
10038 !      logical isnan
10039       logical myisnan
10040       integer i,ib2,ib3,ilostch,ix,j,jj,jj1,lnapx,nthinerr
10041       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
10042      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
10043      &nrco,ntr,nzfz
10044       parameter(npart = 64,nmac = 1)
10045       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
10046      &nzfz = 300000,mmul = 11)
10047       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
10048      &nema = 15)
10049       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10050       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10051       parameter(nmon1 = 600,ncor1 = 600)
10052       parameter(ntr = 20,nbb = 160)
10053       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
10054      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
10055      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10056      &one,pieni,pmae,pmap,three,two,zero
10057       parameter(pieni = 1d-38)
10058       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10059       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10060       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10061       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10062       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
10063      &1.0d16)
10064       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10065       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10066       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10067       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10068       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10069       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10070       parameter(pmap = 938.271998d0,pmae = .510998902d0)
10071       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10072       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
10073      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
10074      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
10075      &imc,imtr,iorg,iout,                                               &
10076      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
10077      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
10078      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
10079      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
10080      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
10081      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
10082      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
10083      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
10084      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10085       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
10086      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10087      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
10088      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10089      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
10090      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
10091      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10092      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
10093      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10094      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
10095      &acdipph
10096       real hmal
10097       character*16 bez,bezb,bezr,erbez,bezl
10098       character*80 toptit,sixtit,commen
10099       common/erro/ierro,erbez
10100       common/kons/pi,pi2,pisqrt,rad
10101       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10102       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10103       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10104       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10105       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10106       common/syos2/rvf(mpa)
10107       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10108      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10109       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
10110      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
10111      &iicav,itionc(nele),ition,idp,ncy,ixcav
10112       common/corcom/dpscor,sigcor,icode,idam,its6d
10113       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
10114      &bka(nele,mmul),aka(nele,mmul)
10115       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10116       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10117       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
10118      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10119       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10120       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10121      &iout
10122       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10123       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
10124      &ntco,eui,euii,nlin,bezl(nele)
10125       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
10126      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
10127      &ncororb(nele)
10128       common/apert/apx(nele),apz(nele),ape(3,nele)
10129       common/clos/sigma0(2),iclo,ncorru,ncorrep
10130       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
10131      &ratioe(nele),iratioe(nele),icoe
10132       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10133       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10134       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10135       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10136       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
10137      &nstart,nstop,iskip,iconv,imad
10138       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10139       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10140       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10141       common/ripp2/nrturn
10142       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10143       common/pawc/hmal(nplo)
10144       common/tit/sixtit,commen,ithick
10145       common/co6d/clo6(3),clop6(3)
10146       common/dkic/dki(nele,3)
10147       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
10148      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
10149      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
10150      &nbeam,ibbc,ibeco,ibtyp,lhc
10151       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10152       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10153       common/wireco/ wirel(nele)
10154       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
10155      &nturn3(nele), nturn4(nele)
10156       integer nnumxv
10157       common/postr2/nnumxv(npart)
10158       integer idz,itra
10159       double precision al,as,chi0,chid,dp1,dps,exz,sigm
10160       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
10161      &dps(mpa),idz(2)
10162       common/anf/chi0,chid,exz(2,6),dp1,itra
10163       integer ichrom,is
10164       double precision alf0,amp,bet0,clo,clop,cro,x,y
10165       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10166       common/chrom/cro(2),is(2),ichrom
10167       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10168      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10169       double precision dpmax,preda,weig1,weig2
10170       character*16 coel
10171       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10172       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10173       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10174      &coel(10)
10175       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10176      &zsi
10177       real tlim,time0,time1
10178       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
10179      &aai(nblz,mmul),bbi(nblz,mmul)
10180       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10181       common/damp/damp,ampt
10182       common/ttime/tlim,time0,time1
10183       double precision tasm
10184       common/tasm/tasm(6,6)
10185       integer iv,ixv,nlostp,nms,numxv
10186       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10187      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10188      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
10189      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10190      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
10191      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
10192      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10193      &zsiv,zsv
10194       logical pstop
10195       common/main1/                                                     &
10196      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
10197      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
10198      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
10199      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
10200      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
10201      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
10202      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
10203      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10204       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
10205      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
10206      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
10207      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
10208      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
10209      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10210      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10211      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
10212      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10213       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
10214      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
10215      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
10216      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10217       integer numx
10218       double precision e0f
10219       common/main4/ e0f,numx
10220       integer ktrack,nwri
10221       double precision dpsv1,strack,strackc,stracks
10222       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
10223      &stracks(nblz),dpsv1(npart),nwri
10224       save
10225 !-----------------------------------------------------------------------
10226       ilostch=0
10227       do 10 j=1,napx
10228         if(xv(1,j)*xv(1,j)*ape(1,ix)+xv(2,j)*xv(2,j)*ape(2,ix).gt.      &
10229      &ape(3,ix).or.                                                     &
10230 !     &isnan(xv(1,j),xv(1,j)).or.isnan(xv(2,j),xv(2,j))) then
10231      &myisnan(xv(1,j),xv(1,j)).or.myisnan(xv(2,j),xv(2,j))) then
10232           ilostch=1
10233           pstop(nlostp(j))=.true.
10234         endif
10235   10  continue
10236       do 20 j=1,napx
10237         if(pstop(nlostp(j))) then
10238           aperv(nlostp(j),1)=apx(ix)
10239           aperv(nlostp(j),2)=apz(ix)
10240           iv(nlostp(j))=i
10241           ixv(nlostp(j))=ix
10242           xvl(1,nlostp(j))=xv(1,j)
10243           xvl(2,nlostp(j))=xv(2,j)
10244           yvl(1,nlostp(j))=yv(1,j)
10245           yvl(2,nlostp(j))=yv(2,j)
10246           dpsvl(nlostp(j))=dpsv(j)
10247           ejvl(nlostp(j))=ejv(j)
10248           sigmvl(nlostp(j))=sigmv(j)
10249           numxv(nlostp(j))=numx
10250           nnumxv(nlostp(j))=numx
10251           if(mod(nlostp(j),2).eq.one) then
10252             write(*,10000) nlostp(j),nms(nlostp(j))*izu0,               &
10253      &dp0v(nlostp(j)),numxv(nlostp(j)),iv(nlostp(j)),                   &
10254      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
10255      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
10256      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
10257           else
10258             write(*,10000) nlostp(j),nms(nlostp(j)-1)*izu0,             &
10259      &dp0v(nlostp(j)-1),numxv(nlostp(j)),iv(nlostp(j)),                 &
10260      &abs(xvl(1,nlostp(j))),aperv(nlostp(j),1),                         &
10261      &abs(xvl(2,nlostp(j))),aperv(nlostp(j),2),                         &
10262      &ixv(nlostp(j)),kz(ixv(nlostp(j))),bez(ixv(nlostp(j)))
10263           endif
10264         endif
10265    20 continue
10266       lnapx=napx
10267       do 30 j=napx,1,-1
10268         if(pstop(nlostp(j))) then
10269           if(j.ne.lnapx) then
10270             do 35 jj=j,lnapx-1
10271               jj1=jj+1
10272               nlostp(jj)=nlostp(jj1)
10273               xv(1,jj)=xv(1,jj1)
10274               xv(2,jj)=xv(2,jj1)
10275               yv(1,jj)=yv(1,jj1)
10276               yv(2,jj)=yv(2,jj1)
10277               dpsv(jj)=dpsv(jj1)
10278               sigmv(jj)=sigmv(jj1)
10279               ejfv(jj)=ejfv(jj1)
10280               ejv(jj)=ejv(jj1)
10281               rvv(jj)=rvv(jj1)
10282               oidpsv(jj)=oidpsv(jj1)
10283               dpsv1(jj)=dpsv1(jj1)
10284               clo6v(1,jj)=clo6v(1,jj1)
10285               clo6v(2,jj)=clo6v(2,jj1)
10286               clo6v(3,jj)=clo6v(3,jj1)
10287               clop6v(1,jj)=clop6v(1,jj1)
10288               clop6v(2,jj)=clop6v(2,jj1)
10289               clop6v(3,jj)=clop6v(3,jj1)
10290 !--beam-beam element
10291               di0xs(jj)=di0xs(jj1)
10292               dip0xs(jj)=dip0xs(jj1)
10293               di0zs(jj)=di0zs(jj1)
10294               dip0zs(jj)=dip0zs(jj1)
10295               do 210 ib2=1,6
10296                 do 210 ib3=1,6
10297                   tasau(jj,ib2,ib3)=tasau(jj1,ib2,ib3)
10298   210         continue
10299    35       continue
10300           endif
10301           lnapx=lnapx-1
10302         endif
10303    30 continue
10304       if(lnapx.eq.0) then
10305         write(*,*)
10306         write(*,*)
10307         write(*,*) '***********************'
10308         write(*,*) '** ALL PARTICLE LOST **'
10309         write(*,*) '**   PROGRAM STOPS   **'
10310         write(*,*) '***********************'
10311         write(*,*)
10312         write(*,*)
10313         nthinerr=3001
10314         return
10315       endif
10316       if(ithick.eq.1.and.ilostch.eq.1)                                  &
10317      &call synuthck
10318       napx=lnapx
10319       return
10320 10000 format(t10,'TRACKING ENDED ABNORMALLY'/t10, 'PARTICLE ',i3,       &
10321      &' RANDOM SEED ',i8, ' MOMENTUM DEVIATION ',g12.5/ t10,            &
10322      &' LOST IN REVOLUTION ',i8,' AT ELEMENT ',i4/ t10,                 &
10323      &'HORIZ:  AMPLITUDE = ',f15.3,'EL-APERTURE = ',f15.3/ t10,         &
10324      &'VERT:   AMPLITUDE = ',f15.3,'EL-APERTURE = ',f15.3/ t10,         &
10325      &'ELEMENT - LIST NUMBER ',i4,' TYP NUMBER ',i4,' NAME ',a16/)
10326       end
10327       subroutine dist1
10328 !-----------------------------------------------------------------------
10329 !
10330 !  F. SCHMIDT
10331 !-----------------------------------------------------------------------
10332 !  3 February 1999
10333 !-----------------------------------------------------------------------
10334       implicit none
10335       integer ia,ib2,ib3,ie
10336       double precision dam1
10337       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
10338      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
10339      &nrco,ntr,nzfz
10340       parameter(npart = 64,nmac = 1)
10341       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
10342      &nzfz = 300000,mmul = 11)
10343       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
10344      &nema = 15)
10345       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10346       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10347       parameter(nmon1 = 600,ncor1 = 600)
10348       parameter(ntr = 20,nbb = 160)
10349       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
10350      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
10351      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10352      &one,pieni,pmae,pmap,three,two,zero
10353       parameter(pieni = 1d-38)
10354       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10355       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10356       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10357       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10358       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
10359      &1.0d16)
10360       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10361       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10362       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10363       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10364       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10365       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10366       parameter(pmap = 938.271998d0,pmae = .510998902d0)
10367       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10368       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
10369      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
10370      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
10371      &imc,imtr,iorg,iout,                                               &
10372      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
10373      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
10374      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
10375      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
10376      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
10377      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
10378      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
10379      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
10380      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10381       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
10382      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10383      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
10384      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10385      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
10386      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
10387      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10388      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
10389      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10390      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
10391      &acdipph
10392       real hmal
10393       character*16 bez,bezb,bezr,erbez,bezl
10394       character*80 toptit,sixtit,commen
10395       common/erro/ierro,erbez
10396       common/kons/pi,pi2,pisqrt,rad
10397       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10398       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10399       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10400       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10401       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10402       common/syos2/rvf(mpa)
10403       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10404      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10405       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
10406      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
10407      &iicav,itionc(nele),ition,idp,ncy,ixcav
10408       common/corcom/dpscor,sigcor,icode,idam,its6d
10409       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
10410      &bka(nele,mmul),aka(nele,mmul)
10411       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10412       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10413       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
10414      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10415       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10416       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10417      &iout
10418       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10419       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
10420      &ntco,eui,euii,nlin,bezl(nele)
10421       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
10422      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
10423      &ncororb(nele)
10424       common/apert/apx(nele),apz(nele),ape(3,nele)
10425       common/clos/sigma0(2),iclo,ncorru,ncorrep
10426       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
10427      &ratioe(nele),iratioe(nele),icoe
10428       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10429       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10430       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10431       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10432       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
10433      &nstart,nstop,iskip,iconv,imad
10434       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10435       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10436       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10437       common/ripp2/nrturn
10438       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10439       common/pawc/hmal(nplo)
10440       common/tit/sixtit,commen,ithick
10441       common/co6d/clo6(3),clop6(3)
10442       common/dkic/dki(nele,3)
10443       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
10444      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
10445      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
10446      &nbeam,ibbc,ibeco,ibtyp,lhc
10447       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10448       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10449       common/wireco/ wirel(nele)
10450       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
10451      &nturn3(nele), nturn4(nele)
10452       integer idz,itra
10453       double precision al,as,chi0,chid,dp1,dps,exz,sigm
10454       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
10455      &dps(mpa),idz(2)
10456       common/anf/chi0,chid,exz(2,6),dp1,itra
10457       integer ichrom,is
10458       double precision alf0,amp,bet0,clo,clop,cro,x,y
10459       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10460       common/chrom/cro(2),is(2),ichrom
10461       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10462      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10463       double precision dpmax,preda,weig1,weig2
10464       character*16 coel
10465       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10466       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10467       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10468      &coel(10)
10469       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10470      &zsi
10471       real tlim,time0,time1
10472       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
10473      &aai(nblz,mmul),bbi(nblz,mmul)
10474       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10475       common/damp/damp,ampt
10476       common/ttime/tlim,time0,time1
10477       double precision tasm
10478       common/tasm/tasm(6,6)
10479       integer iv,ixv,nlostp,nms,numxv
10480       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10481      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10482      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
10483      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10484      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
10485      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
10486      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10487      &zsiv,zsv
10488       logical pstop
10489       common/main1/                                                     &
10490      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
10491      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
10492      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
10493      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
10494      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
10495      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
10496      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
10497      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10498       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
10499      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
10500      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
10501      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
10502      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
10503      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10504      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10505      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
10506      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10507       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
10508      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
10509      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
10510      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10511       integer numx
10512       double precision e0f
10513       common/main4/ e0f,numx
10514       integer ktrack,nwri
10515       double precision dpsv1,strack,strackc,stracks
10516       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
10517      &stracks(nblz),dpsv1(npart),nwri
10518       save
10519 !-----------------------------------------------------------------------
10520       do 20 ia=1,napx,2
10521         if(.not.pstop(nlostp(ia)).and..not.pstop(nlostp(ia)+1).and.     &
10522      &(mod(nlostp(ia),2).ne.0)) then
10523           ie=ia+1
10524           dam(ia)=zero
10525           dam(ie)=zero
10526           xau(1,1)= xv(1,ia)
10527           xau(1,2)= yv(1,ia)
10528           xau(1,3)= xv(2,ia)
10529           xau(1,4)= yv(2,ia)
10530           xau(1,5)=sigmv(ia)
10531           xau(1,6)= dpsv(ia)
10532           xau(2,1)= xv(1,ie)
10533           xau(2,2)= yv(1,ie)
10534           xau(2,3)= xv(2,ie)
10535           xau(2,4)= yv(2,ie)
10536           xau(2,5)=sigmv(ie)
10537           xau(2,6)= dpsv(ie)
10538           cloau(1)= clo6v(1,ia)
10539           cloau(2)=clop6v(1,ia)
10540           cloau(3)= clo6v(2,ia)
10541           cloau(4)=clop6v(2,ia)
10542           cloau(5)= clo6v(3,ia)
10543           cloau(6)=clop6v(3,ia)
10544           di0au(1)= di0xs(ia)
10545           di0au(2)=dip0xs(ia)
10546           di0au(3)= di0zs(ia)
10547           di0au(4)=dip0zs(ia)
10548           do 10 ib2=1,6
10549             do 10 ib3=1,6
10550               tau(ib2,ib3)=tasau(ia,ib2,ib3)
10551    10     continue
10552           call distance(xau,cloau,di0au,tau,dam1)
10553           dam(ia)=dam1
10554           dam(ie)=dam1
10555         endif
10556    20 continue
10557       return
10558       end
10559       subroutine write6(n)
10560 !-----------------------------------------------------------------------
10561 !
10562 !  F. SCHMIDT
10563 !-----------------------------------------------------------------------
10564 !  3 February 1999
10565 !-----------------------------------------------------------------------
10566       implicit none
10567       integer ia,ia2,id,ie,ig,n
10568       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
10569      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
10570      &nrco,ntr,nzfz
10571       parameter(npart = 64,nmac = 1)
10572       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
10573      &nzfz = 300000,mmul = 11)
10574       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
10575      &nema = 15)
10576       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10577       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10578       parameter(nmon1 = 600,ncor1 = 600)
10579       parameter(ntr = 20,nbb = 160)
10580       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
10581      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
10582      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10583      &one,pieni,pmae,pmap,three,two,zero
10584       parameter(pieni = 1d-38)
10585       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10586       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10587       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10588       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10589       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
10590      &1.0d16)
10591       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10592       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10593       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10594       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10595       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10596       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10597       parameter(pmap = 938.271998d0,pmae = .510998902d0)
10598       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10599       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
10600      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
10601      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
10602      &imc,imtr,iorg,iout,                                               &
10603      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
10604      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
10605      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
10606      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
10607      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
10608      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
10609      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
10610      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
10611      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10612       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
10613      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10614      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
10615      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10616      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
10617      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
10618      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10619      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
10620      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10621      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
10622      &acdipph
10623       real hmal
10624       character*16 bez,bezb,bezr,erbez,bezl
10625       character*80 toptit,sixtit,commen
10626       common/erro/ierro,erbez
10627       common/kons/pi,pi2,pisqrt,rad
10628       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10629       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10630       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10631       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10632       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10633       common/syos2/rvf(mpa)
10634       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10635      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10636       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
10637      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
10638      &iicav,itionc(nele),ition,idp,ncy,ixcav
10639       common/corcom/dpscor,sigcor,icode,idam,its6d
10640       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
10641      &bka(nele,mmul),aka(nele,mmul)
10642       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10643       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10644       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
10645      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10646       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10647       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10648      &iout
10649       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10650       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
10651      &ntco,eui,euii,nlin,bezl(nele)
10652       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
10653      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
10654      &ncororb(nele)
10655       common/apert/apx(nele),apz(nele),ape(3,nele)
10656       common/clos/sigma0(2),iclo,ncorru,ncorrep
10657       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
10658      &ratioe(nele),iratioe(nele),icoe
10659       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10660       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10661       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10662       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10663       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
10664      &nstart,nstop,iskip,iconv,imad
10665       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10666       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10667       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10668       common/ripp2/nrturn
10669       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10670       common/pawc/hmal(nplo)
10671       common/tit/sixtit,commen,ithick
10672       common/co6d/clo6(3),clop6(3)
10673       common/dkic/dki(nele,3)
10674       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
10675      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
10676      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
10677      &nbeam,ibbc,ibeco,ibtyp,lhc
10678       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10679       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10680       common/wireco/ wirel(nele)
10681       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
10682      &nturn3(nele), nturn4(nele)
10683       integer nnumxv
10684       common/postr2/nnumxv(npart)
10685       integer idz,itra
10686       double precision al,as,chi0,chid,dp1,dps,exz,sigm
10687       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
10688      &dps(mpa),idz(2)
10689       common/anf/chi0,chid,exz(2,6),dp1,itra
10690       integer ichrom,is
10691       double precision alf0,amp,bet0,clo,clop,cro,x,y
10692       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10693       common/chrom/cro(2),is(2),ichrom
10694       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10695      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10696       double precision dpmax,preda,weig1,weig2
10697       character*16 coel
10698       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10699       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10700       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10701      &coel(10)
10702       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10703      &zsi
10704       real tlim,time0,time1
10705       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
10706      &aai(nblz,mmul),bbi(nblz,mmul)
10707       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10708       common/damp/damp,ampt
10709       common/ttime/tlim,time0,time1
10710       double precision tasm
10711       common/tasm/tasm(6,6)
10712       integer iv,ixv,nlostp,nms,numxv
10713       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10714      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10715      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
10716      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10717      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
10718      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
10719      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10720      &zsiv,zsv
10721       logical pstop
10722       common/main1/                                                     &
10723      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
10724      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
10725      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
10726      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
10727      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
10728      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
10729      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
10730      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10731       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
10732      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
10733      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
10734      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
10735      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
10736      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10737      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10738      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
10739      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10740       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
10741      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
10742      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
10743      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10744       integer numx
10745       double precision e0f
10746       common/main4/ e0f,numx
10747       integer ktrack,nwri
10748       double precision dpsv1,strack,strackc,stracks
10749       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
10750      &stracks(nblz),dpsv1(npart),nwri
10751       save
10752 !-----------------------------------------------------------------------
10753       id=0
10754       do 10 ia=1,napxo,2
10755         ig=ia+1
10756         ia2=ig/2
10757         endfile 91-ia2
10758         backspace 91-ia2
10759 !-- PARTICLES STABLE
10760         if(.not.pstop(ia).and..not.pstop(ig)) then
10761           write(*,10000) ia,nms(ia)*izu0,dp0v(ia),n
10762           id=id+1
10763           ie=id+1
10764           write(*,10010)                                                &
10765      &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id),           &
10766      &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie),           &
10767      &e0,ejv(id),ejv(ie)
10768           write(12,10010,iostat=ierro)                                  &
10769      &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id),           &
10770      &xv(1,ie),yv(1,ie),xv(2,ie),yv(2,ie),sigmv(ie),dpsv(ie),           &
10771      &e0,ejv(id),ejv(ie)
10772           id=id+1
10773 !-- FIRST PARTICLES LOST
10774         else if(pstop(ia).and..not.pstop(ig)) then
10775           id=id+1
10776           write(12,10010,iostat=ierro)                                  &
10777      &xvl(1,ia),yvl(1,ia),xvl(2,ia),yvl(2,ia),sigmvl(ia),dpsvl(ia),     &
10778      &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id),           &
10779      &e0,ejvl(ia),ejv(id)
10780 !-- SECOND PARTICLES LOST
10781         else if(.not.pstop(ia).and.pstop(ig)) then
10782           id=id+1
10783           write(12,10010,iostat=ierro)                                  &
10784      &xv(1,id),yv(1,id),xv(2,id),yv(2,id),sigmv(id),dpsv(id),           &
10785      &xvl(1,ig),yvl(1,ig),xvl(2,ig),yvl(2,ig),sigmvl(ig),dpsvl(ig),     &
10786      &e0,ejv(id),ejvl(ig)
10787 !-- BOTH PARTICLES LOST
10788         else if(pstop(ia).and.pstop(ig)) then
10789         endif
10790    10 continue
10791       if(ierro.ne.0) write(*,*) 'Warning from write6: fort.12 has ',    &
10792      &'corrupted output probably due to lost particles'
10793       endfile 12
10794       backspace 12
10795       return
10796 10000 format(1x/5x,'PARTICLE ',i3,' RANDOM SEED ',i8,                   &
10797      &' MOMENTUM DEVIATION ',g12.5 /5x,'REVOLUTION ',i8/)
10798 10010 format(10x,f47.33)
10799       end
10800       subroutine trauthck(nthinerr)
10801 !-----------------------------------------------------------------------
10802 !
10803 !  TRACK THICK LENS PART
10804 !
10805 !
10806 !  F. SCHMIDT
10807 !-----------------------------------------------------------------------
10808       implicit none
10809       integer i,ix,j,jb,jj,jx,kpz,kzz,napx0,nbeaux,nmz,nthinerr
10810       double precision benkcc,cbxb,cbzb,cikveb,crkveb,crxb,crzb,r0,r000,&
10811      &r0a,r2b,rb,rho2b,rkb,tkb,xbb,xrb,zbb,zrb
10812       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
10813      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
10814      &nrco,ntr,nzfz
10815       parameter(npart = 64,nmac = 1)
10816       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
10817      &nzfz = 300000,mmul = 11)
10818       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
10819      &nema = 15)
10820       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
10821       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
10822       parameter(nmon1 = 600,ncor1 = 600)
10823       parameter(ntr = 20,nbb = 160)
10824       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
10825      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
10826      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
10827      &one,pieni,pmae,pmap,three,two,zero
10828       parameter(pieni = 1d-38)
10829       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
10830       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
10831       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
10832       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
10833       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
10834      &1.0d16)
10835       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
10836       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
10837       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
10838       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
10839       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
10840       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
10841       parameter(pmap = 938.271998d0,pmae = .510998902d0)
10842       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
10843       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
10844      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
10845      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
10846      &imc,imtr,iorg,iout,                                               &
10847      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
10848      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
10849      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
10850      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
10851      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
10852      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
10853      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
10854      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
10855      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
10856       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
10857      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
10858      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
10859      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
10860      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
10861      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
10862      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
10863      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
10864      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
10865      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
10866      &acdipph
10867       real hmal
10868       character*16 bez,bezb,bezr,erbez,bezl
10869       character*80 toptit,sixtit,commen
10870       common/erro/ierro,erbez
10871       common/kons/pi,pi2,pisqrt,rad
10872       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
10873       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
10874       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
10875       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
10876       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
10877       common/syos2/rvf(mpa)
10878       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
10879      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
10880       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
10881      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
10882      &iicav,itionc(nele),ition,idp,ncy,ixcav
10883       common/corcom/dpscor,sigcor,icode,idam,its6d
10884       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
10885      &bka(nele,mmul),aka(nele,mmul)
10886       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
10887       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
10888       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
10889      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
10890       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
10891       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
10892      &iout
10893       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
10894       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
10895      &ntco,eui,euii,nlin,bezl(nele)
10896       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
10897      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
10898      &ncororb(nele)
10899       common/apert/apx(nele),apz(nele),ape(3,nele)
10900       common/clos/sigma0(2),iclo,ncorru,ncorrep
10901       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
10902      &ratioe(nele),iratioe(nele),icoe
10903       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
10904       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
10905       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
10906       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
10907       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
10908      &nstart,nstop,iskip,iconv,imad
10909       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
10910       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
10911       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
10912       common/ripp2/nrturn
10913       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
10914       common/pawc/hmal(nplo)
10915       common/tit/sixtit,commen,ithick
10916       common/co6d/clo6(3),clop6(3)
10917       common/dkic/dki(nele,3)
10918       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
10919      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
10920      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
10921      &nbeam,ibbc,ibeco,ibtyp,lhc
10922       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
10923       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
10924       common/wireco/ wirel(nele)
10925       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
10926      &nturn3(nele), nturn4(nele)
10927       integer idz,itra
10928       double precision al,as,chi0,chid,dp1,dps,exz,sigm
10929       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
10930      &dps(mpa),idz(2)
10931       common/anf/chi0,chid,exz(2,6),dp1,itra
10932       integer ichrom,is
10933       double precision alf0,amp,bet0,clo,clop,cro,x,y
10934       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
10935       common/chrom/cro(2),is(2),ichrom
10936       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
10937      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
10938       double precision dpmax,preda,weig1,weig2
10939       character*16 coel
10940       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
10941       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
10942       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
10943      &coel(10)
10944       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
10945      &zsi
10946       real tlim,time0,time1
10947       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
10948      &aai(nblz,mmul),bbi(nblz,mmul)
10949       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
10950       common/damp/damp,ampt
10951       common/ttime/tlim,time0,time1
10952       double precision tasm
10953       common/tasm/tasm(6,6)
10954       integer iv,ixv,nlostp,nms,numxv
10955       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
10956      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
10957      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
10958      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
10959      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
10960      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
10961      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
10962      &zsiv,zsv
10963       logical pstop
10964       common/main1/                                                     &
10965      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
10966      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
10967      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
10968      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
10969      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
10970      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
10971      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
10972      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
10973       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
10974      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
10975      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
10976      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
10977      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
10978      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
10979      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
10980      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
10981      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
10982       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
10983      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
10984      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
10985      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
10986       integer numx
10987       double precision e0f
10988       common/main4/ e0f,numx
10989       integer ktrack,nwri
10990       double precision dpsv1,strack,strackc,stracks
10991       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
10992      &stracks(nblz),dpsv1(npart),nwri
10993       double precision cc,xlim,ylim
10994       parameter(cc = 1.12837916709551d0)
10995       parameter(xlim = 5.33d0)
10996       parameter(ylim = 4.29d0)
10997       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
10998      &r2b(npart),rb(npart),rkb(npart),                                  &
10999      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
11000      &crzb(npart),cbxb(npart),cbzb(npart)
11001       dimension nbeaux(nbb)
11002       save
11003 !-----------------------------------------------------------------------
11004       do 5 i=1,npart
11005         nlostp(i)=i
11006    5  continue
11007       do 10 i=1,nblz
11008         ktrack(i)=0
11009         strack(i)=zero
11010         strackc(i)=zero
11011         stracks(i)=zero
11012    10 continue
11013 !--beam-beam element
11014       if(nbeam.ge.1) then
11015         do 15 i=1,nbb
11016           nbeaux(i)=0
11017    15   continue
11018         do i=1,iu
11019           ix=ic(i)
11020           if(ix.gt.nblo) then
11021             ix=ix-nblo
11022             if(kz(ix).eq.20.and.parbe(ix,2).eq.0) then
11023 !--round beam
11024               if(sigman(1,imbb(i)).eq.sigman(2,imbb(i))) then
11025                 if(nbeaux(imbb(i)).eq.2.or.nbeaux(imbb(i)).eq.3) then
11026                   call prror(89)
11027                 else
11028                   nbeaux(imbb(i))=1
11029                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11030                 endif
11031               endif
11032 !--elliptic beam x>z
11033               if(sigman(1,imbb(i)).gt.sigman(2,imbb(i))) then
11034                 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.3) then
11035                   call prror(89)
11036                 else
11037                   nbeaux(imbb(i))=2
11038                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11039                   sigman2(2,imbb(i))=sigman(2,imbb(i))**2
11040                   sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
11041                   sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
11042                 endif
11043               endif
11044 !--elliptic beam z>x
11045               if(sigman(1,imbb(i)).lt.sigman(2,imbb(i))) then
11046                 if(nbeaux(imbb(i)).eq.1.or.nbeaux(imbb(i)).eq.2) then
11047                   call prror(89)
11048                 else
11049                   nbeaux(imbb(i))=3
11050                   sigman2(1,imbb(i))=sigman(1,imbb(i))**2
11051                   sigman2(2,imbb(i))=sigman(2,imbb(i))**2
11052                   sigmanq(1,imbb(i))=sigman(1,imbb(i))/sigman(2,imbb(i))
11053                   sigmanq(2,imbb(i))=sigman(2,imbb(i))/sigman(1,imbb(i))
11054                 endif
11055               endif
11056             endif
11057           endif
11058         enddo
11059       endif
11060       do 290 i=1,iu
11061         if(mout2.eq.1.and.i.eq.1) call write4
11062         ix=ic(i)
11063         if(ix.gt.nblo) goto 30
11064         ktrack(i)=1
11065         do 20 jb=1,mel(ix)
11066           jx=mtyp(ix,jb)
11067           strack(i)=strack(i)+el(jx)
11068    20   continue
11069         if(abs(strack(i)).le.pieni) ktrack(i)=31
11070         goto 290
11071    30   ix=ix-nblo
11072         kpz=abs(kp(ix))
11073         if(kpz.eq.6) then
11074           ktrack(i)=2
11075           goto 290
11076         endif
11077    40   kzz=kz(ix)
11078         if(kzz.eq.0) then
11079           ktrack(i)=31
11080           goto 290
11081         endif
11082 !--beam-beam element
11083         if(kzz.eq.20.and.nbeam.ge.1.and.parbe(ix,2).eq.0) then
11084           strack(i)=crad*ptnfac(ix)
11085           if(abs(strack(i)).le.pieni) then
11086             ktrack(i)=31
11087             goto 290
11088           endif
11089           if(nbeaux(imbb(i)).eq.1) then
11090             ktrack(i)=41
11091             if(ibeco.eq.1) then
11092               do 42 j=1,napx
11093               if(ibbc.eq.0) then
11094                 crkveb(j)=ed(ix)
11095                 cikveb(j)=ek(ix)
11096               else
11097                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
11098      &ek(ix)*bbcu(imbb(i),12)
11099                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
11100      &ek(ix)*bbcu(imbb(i),11)
11101               endif
11102             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
11103             if(rho2b(j).le.pieni)                                       &
11104      &goto 42
11105             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
11106                 beamoff(4,imbb(i))=strack(i)*crkveb(j)/rho2b(j)*        &
11107      &(one-exp(-tkb(j)))
11108                 beamoff(5,imbb(i))=strack(i)*cikveb(j)/rho2b(j)*        &
11109      &(one-exp(-tkb(j)))
11110    42         continue
11111             endif
11112           endif
11113           if(nbeaux(imbb(i)).eq.2) then
11114             ktrack(i)=42
11115             if(ibeco.eq.1) then
11116             if(ibtyp.eq.0) then
11117             do j=1,napx
11118               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
11119               rb(j)=sqrt(r2b(j))
11120               rkb(j)=strack(i)*pisqrt/rb(j)
11121               if(ibbc.eq.0) then
11122                 crkveb(j)=ed(ix)
11123                 cikveb(j)=ek(ix)
11124               else
11125                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
11126      &ek(ix)*bbcu(imbb(i),12)
11127                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
11128      &ek(ix)*bbcu(imbb(i),11)
11129               endif
11130               xrb(j)=abs(crkveb(j))/rb(j)
11131               zrb(j)=abs(cikveb(j))/rb(j)
11132               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
11133               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
11134      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11135               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11136               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11137               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
11138               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11139      &sign(one,crkveb(j))
11140               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11141      &sign(one,cikveb(j))
11142             enddo
11143             else if(ibtyp.eq.1) then
11144             do j=1,napx
11145               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
11146               rb(j)=sqrt(r2b(j))
11147               rkb(j)=strack(i)*pisqrt/rb(j)
11148               if(ibbc.eq.0) then
11149                 crkveb(j)=ed(ix)
11150                 cikveb(j)=ek(ix)
11151               else
11152                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
11153      &ek(ix)*bbcu(imbb(i),12)
11154                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
11155      &ek(ix)*bbcu(imbb(i),11)
11156               endif
11157               xrb(j)=abs(crkveb(j))/rb(j)
11158               zrb(j)=abs(cikveb(j))/rb(j)
11159               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
11160      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11161               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11162               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11163             enddo
11164             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
11165             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
11166             do j=1,napx
11167               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11168      &sign(one,crkveb(j))
11169               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11170      &sign(one,cikveb(j))
11171             enddo
11172             endif
11173             endif
11174           endif
11175           if(nbeaux(imbb(i)).eq.3) then
11176             ktrack(i)=43
11177             if(ibeco.eq.1) then
11178             if(ibtyp.eq.0) then
11179             do j=1,napx
11180               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
11181               rb(j)=sqrt(r2b(j))
11182               rkb(j)=strack(i)*pisqrt/rb(j)
11183               if(ibbc.eq.0) then
11184                 crkveb(j)=ed(ix)
11185                 cikveb(j)=ek(ix)
11186               else
11187                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
11188      &ek(ix)*bbcu(imbb(i),12)
11189                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
11190      &ek(ix)*bbcu(imbb(i),11)
11191               endif
11192               xrb(j)=abs(crkveb(j))/rb(j)
11193               zrb(j)=abs(cikveb(j))/rb(j)
11194               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
11195               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
11196      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11197               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11198               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11199               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
11200               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11201      &sign(one,crkveb(j))
11202               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11203      &sign(one,cikveb(j))
11204             enddo
11205             else if(ibtyp.eq.1) then
11206             do j=1,napx
11207               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
11208               rb(j)=sqrt(r2b(j))
11209               rkb(j)=strack(i)*pisqrt/rb(j)
11210               if(ibbc.eq.0) then
11211                 crkveb(j)=ed(ix)
11212                 cikveb(j)=ek(ix)
11213               else
11214                 crkveb(j)=ed(ix)*bbcu(imbb(i),11)+                      &
11215      &ek(ix)*bbcu(imbb(i),12)
11216                 cikveb(j)=-ed(ix)*bbcu(imbb(i),12)+                     &
11217      &ek(ix)*bbcu(imbb(i),11)
11218               endif
11219               xrb(j)=abs(crkveb(j))/rb(j)
11220               zrb(j)=abs(cikveb(j))/rb(j)
11221               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
11222      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
11223               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
11224               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
11225             enddo
11226             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
11227             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
11228             do j=1,napx
11229               beamoff(4,imbb(i))=rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))* &
11230      &sign(one,crkveb(j))
11231               beamoff(5,imbb(i))=rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))* &
11232      &sign(one,cikveb(j))
11233             enddo
11234             endif
11235             endif
11236           endif
11237           goto 290
11238 !--Hirata's 6D beam-beam kick
11239         else if(kzz.eq.20.and.parbe(ix,2).gt.0) then
11240           ktrack(i)=44
11241           parbe(ix,4)=-crad*ptnfac(ix)*half*c1m6
11242           if(ibeco.eq.1) then
11243             track6d(1,1)=ed(ix)*c1m3
11244             track6d(2,1)=zero
11245             track6d(3,1)=ek(ix)*c1m3
11246             track6d(4,1)=zero
11247             track6d(5,1)=zero
11248             track6d(6,1)=zero
11249             napx0=napx
11250             napx=1
11251             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
11252      &ibbc)
11253             beamoff(1,imbb(i))=track6d(1,1)*c1e3
11254             beamoff(2,imbb(i))=track6d(3,1)*c1e3
11255             beamoff(4,imbb(i))=track6d(2,1)*c1e3
11256             beamoff(5,imbb(i))=track6d(4,1)*c1e3
11257             beamoff(6,imbb(i))=track6d(6,1)
11258             napx=napx0
11259           endif
11260           goto 290
11261         endif
11262         if(kzz.eq.15) then
11263           ktrack(i)=45
11264           goto 290
11265         endif
11266         if(kzz.eq.16) then
11267           ktrack(i)=51
11268           goto 290
11269         else if(kzz.eq.-16) then
11270           ktrack(i)=52
11271           goto 290
11272         endif
11273         if(kzz.eq.22) then
11274           ktrack(i)=3
11275           goto 290
11276         endif
11277         if(mout2.eq.1.and.icextal(i).ne.0) then
11278           write(27,'(a16,2x,1p,2d14.6,d17.9)') bez(ix),extalign(i,1),   &
11279      &extalign(i,2),extalign(i,3)
11280         endif
11281         if(kzz.lt.0) goto 180
11282         goto(50,60,70,80,90,100,110,120,130,140,150),kzz
11283         ktrack(i)=31
11284         goto 290
11285    50   if(abs(smiv(1,i)).le.pieni) then
11286           ktrack(i)=31
11287           goto 290
11288         endif
11289         ktrack(i)=11
11290         strack(i)=smiv(1,i)*c1e3
11291         strackc(i)=strack(i)*tiltc(i)
11292         stracks(i)=strack(i)*tilts(i)
11293         goto 290
11294    60   if(abs(smiv(1,i)).le.pieni.and.abs(ramp(ix)).le.pieni) then
11295           ktrack(i)=31
11296           goto 290
11297         endif
11298         ktrack(i)=12
11299         strack(i)=smiv(1,i)
11300         strackc(i)=strack(i)*tiltc(i)
11301         stracks(i)=strack(i)*tilts(i)
11302         goto 290
11303    70   if(abs(smiv(1,i)).le.pieni) then
11304           ktrack(i)=31
11305           goto 290
11306         endif
11307         ktrack(i)=13
11308         strack(i)=smiv(1,i)*c1m3
11309         strackc(i)=strack(i)*tiltc(i)
11310         stracks(i)=strack(i)*tilts(i)
11311         goto 290
11312    80   if(abs(smiv(1,i)).le.pieni) then
11313           ktrack(i)=31
11314           goto 290
11315         endif
11316         ktrack(i)=14
11317         strack(i)=smiv(1,i)*c1m6
11318         strackc(i)=strack(i)*tiltc(i)
11319         stracks(i)=strack(i)*tilts(i)
11320         goto 290
11321    90   if(abs(smiv(1,i)).le.pieni) then
11322           ktrack(i)=31
11323           goto 290
11324         endif
11325         ktrack(i)=15
11326         strack(i)=smiv(1,i)*c1m9
11327         strackc(i)=strack(i)*tiltc(i)
11328         stracks(i)=strack(i)*tilts(i)
11329         goto 290
11330   100   if(abs(smiv(1,i)).le.pieni) then
11331           ktrack(i)=31
11332           goto 290
11333         endif
11334         ktrack(i)=16
11335         strack(i)=smiv(1,i)*c1m12
11336         strackc(i)=strack(i)*tiltc(i)
11337         stracks(i)=strack(i)*tilts(i)
11338         goto 290
11339   110   if(abs(smiv(1,i)).le.pieni) then
11340           ktrack(i)=31
11341           goto 290
11342         endif
11343         ktrack(i)=17
11344         strack(i)=smiv(1,i)*c1m15
11345         strackc(i)=strack(i)*tiltc(i)
11346         stracks(i)=strack(i)*tilts(i)
11347         goto 290
11348   120   if(abs(smiv(1,i)).le.pieni) then
11349           ktrack(i)=31
11350           goto 290
11351         endif
11352         ktrack(i)=18
11353         strack(i)=smiv(1,i)*c1m18
11354         strackc(i)=strack(i)*tiltc(i)
11355         stracks(i)=strack(i)*tilts(i)
11356         goto 290
11357   130   if(abs(smiv(1,i)).le.pieni) then
11358           ktrack(i)=31
11359           goto 290
11360         endif
11361         ktrack(i)=19
11362         strack(i)=smiv(1,i)*c1m21
11363         strackc(i)=strack(i)*tiltc(i)
11364         stracks(i)=strack(i)*tilts(i)
11365         goto 290
11366   140   if(abs(smiv(1,i)).le.pieni) then
11367           ktrack(i)=31
11368           goto 290
11369         endif
11370         ktrack(i)=20
11371         strack(i)=smiv(1,i)*c1m24
11372         strackc(i)=strack(i)*tiltc(i)
11373         stracks(i)=strack(i)*tilts(i)
11374         goto 290
11375   150   r0=ek(ix)
11376         nmz=nmu(ix)
11377         if(abs(r0).le.pieni.or.nmz.eq.0) then
11378           if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
11379             ktrack(i)=31
11380           else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni)  &
11381      &then
11382             if(abs(dki(ix,3)).gt.pieni) then
11383               ktrack(i)=33
11384               strack(i)=dki(ix,1)/dki(ix,3)
11385               strackc(i)=strack(i)*tiltc(i)
11386               stracks(i)=strack(i)*tilts(i)
11387             else
11388               ktrack(i)=35
11389               strack(i)=dki(ix,1)
11390               strackc(i)=strack(i)*tiltc(i)
11391               stracks(i)=strack(i)*tilts(i)
11392             endif
11393           else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni)  &
11394      &then
11395             if(abs(dki(ix,3)).gt.pieni) then
11396               ktrack(i)=37
11397               strack(i)=dki(ix,2)/dki(ix,3)
11398               strackc(i)=strack(i)*tiltc(i)
11399               stracks(i)=strack(i)*tilts(i)
11400             else
11401               ktrack(i)=39
11402               strack(i)=dki(ix,2)
11403               strackc(i)=strack(i)*tiltc(i)
11404               stracks(i)=strack(i)*tilts(i)
11405             endif
11406           endif
11407         else
11408           if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).le.pieni) then
11409             ktrack(i)=32
11410           else if(abs(dki(ix,1)).gt.pieni.and.abs(dki(ix,2)).le.pieni)  &
11411      &then
11412             if(abs(dki(ix,3)).gt.pieni) then
11413               ktrack(i)=34
11414               strack(i)=dki(ix,1)/dki(ix,3)
11415               strackc(i)=strack(i)*tiltc(i)
11416               stracks(i)=strack(i)*tilts(i)
11417             else
11418               ktrack(i)=36
11419               strack(i)=dki(ix,1)
11420               strackc(i)=strack(i)*tiltc(i)
11421               stracks(i)=strack(i)*tilts(i)
11422             endif
11423           else if(abs(dki(ix,1)).le.pieni.and.abs(dki(ix,2)).gt.pieni)  &
11424      &then
11425             if(abs(dki(ix,3)).gt.pieni) then
11426               ktrack(i)=38
11427               strack(i)=dki(ix,2)/dki(ix,3)
11428               strackc(i)=strack(i)*tiltc(i)
11429               stracks(i)=strack(i)*tilts(i)
11430             else
11431               ktrack(i)=40
11432               strack(i)=dki(ix,2)
11433               strackc(i)=strack(i)*tiltc(i)
11434               stracks(i)=strack(i)*tilts(i)
11435             endif
11436           endif
11437         endif
11438         if(abs(r0).le.pieni.or.nmz.eq.0) goto 290
11439         if(mout2.eq.1) then
11440           benkcc=ed(ix)*benkc(irm(ix))
11441           r0a=one
11442           r000=r0*r00(irm(ix))
11443           do 160 j=1,mmul
11444             fake(1,j)=bbiv(j,1,i)*r0a/benkcc
11445             fake(2,j)=aaiv(j,1,i)*r0a/benkcc
11446   160     r0a=r0a*r000
11447           write(9,'(a16)') bez(ix)
11448           write(9,'(1p,3d23.15)') (fake(1,j), j=1,3)
11449           write(9,'(1p,3d23.15)') (fake(1,j), j=4,6)
11450           write(9,'(1p,3d23.15)') (fake(1,j), j=7,9)
11451           write(9,'(1p,3d23.15)') (fake(1,j), j=10,12)
11452           write(9,'(1p,3d23.15)') (fake(1,j), j=13,15)
11453           write(9,'(1p,3d23.15)') (fake(1,j), j=16,18)
11454           write(9,'(1p,2d23.15)') (fake(1,j), j=19,20)
11455           write(9,'(1p,3d23.15)') (fake(2,j), j=1,3)
11456           write(9,'(1p,3d23.15)') (fake(2,j), j=4,6)
11457           write(9,'(1p,3d23.15)') (fake(2,j), j=7,9)
11458           write(9,'(1p,3d23.15)') (fake(2,j), j=10,12)
11459           write(9,'(1p,3d23.15)') (fake(2,j), j=13,15)
11460           write(9,'(1p,3d23.15)') (fake(2,j), j=16,18)
11461           write(9,'(1p,2d23.15)') (fake(2,j), j=19,20)
11462           do 170 j=1,20
11463             fake(1,j)=zero
11464   170     fake(2,j)=zero
11465         endif
11466         goto 290
11467   180   kzz=-kzz
11468         goto(190,200,210,220,230,240,250,260,270,280),kzz
11469         ktrack(i)=31
11470         goto 290
11471   190   if(abs(smiv(1,i)).le.pieni) then
11472           ktrack(i)=31
11473           goto 290
11474         endif
11475         ktrack(i)=21
11476         strack(i)=smiv(1,i)*c1e3
11477         strackc(i)=strack(i)*tiltc(i)
11478         stracks(i)=strack(i)*tilts(i)
11479         goto 290
11480   200   if(abs(smiv(1,i)).le.pieni) then
11481           ktrack(i)=31
11482           goto 290
11483         endif
11484         ktrack(i)=22
11485         strack(i)=smiv(1,i)
11486         strackc(i)=strack(i)*tiltc(i)
11487         stracks(i)=strack(i)*tilts(i)
11488         goto 290
11489   210   if(abs(smiv(1,i)).le.pieni) then
11490           ktrack(i)=31
11491           goto 290
11492         endif
11493         ktrack(i)=23
11494         strack(i)=smiv(1,i)*c1m3
11495         strackc(i)=strack(i)*tiltc(i)
11496         stracks(i)=strack(i)*tilts(i)
11497         goto 290
11498   220   if(abs(smiv(1,i)).le.pieni) then
11499           ktrack(i)=31
11500           goto 290
11501         endif
11502         ktrack(i)=24
11503         strack(i)=smiv(1,i)*c1m6
11504         strackc(i)=strack(i)*tiltc(i)
11505         stracks(i)=strack(i)*tilts(i)
11506         goto 290
11507   230   if(abs(smiv(1,i)).le.pieni) then
11508           ktrack(i)=31
11509           goto 290
11510         endif
11511         ktrack(i)=25
11512         strack(i)=smiv(1,i)*c1m9
11513         strackc(i)=strack(i)*tiltc(i)
11514         stracks(i)=strack(i)*tilts(i)
11515         goto 290
11516   240   if(abs(smiv(1,i)).le.pieni) then
11517           ktrack(i)=31
11518           goto 290
11519         endif
11520         ktrack(i)=26
11521         strack(i)=smiv(1,i)*c1m12
11522         strackc(i)=strack(i)*tiltc(i)
11523         stracks(i)=strack(i)*tilts(i)
11524         goto 290
11525   250   if(abs(smiv(1,i)).le.pieni) then
11526           ktrack(i)=31
11527           goto 290
11528         endif
11529         ktrack(i)=27
11530         strack(i)=smiv(1,i)*c1m15
11531         strackc(i)=strack(i)*tiltc(i)
11532         stracks(i)=strack(i)*tilts(i)
11533         goto 290
11534   260   if(abs(smiv(1,i)).le.pieni) then
11535           ktrack(i)=31
11536           goto 290
11537         endif
11538         ktrack(i)=28
11539         strack(i)=smiv(1,i)*c1m18
11540         strackc(i)=strack(i)*tiltc(i)
11541         stracks(i)=strack(i)*tilts(i)
11542         goto 290
11543   270   if(abs(smiv(1,i)).le.pieni) then
11544           ktrack(i)=31
11545           goto 290
11546         endif
11547         ktrack(i)=29
11548         strack(i)=smiv(1,i)*c1m21
11549         strackc(i)=strack(i)*tiltc(i)
11550         stracks(i)=strack(i)*tilts(i)
11551         goto 290
11552   280   if(abs(smiv(1,i)).le.pieni) then
11553           ktrack(i)=31
11554           goto 290
11555         endif
11556         ktrack(i)=30
11557         strack(i)=smiv(1,i)*c1m24
11558         strackc(i)=strack(i)*tiltc(i)
11559         stracks(i)=strack(i)*tilts(i)
11560   290 continue
11561       do 300 j=1,napx
11562         dpsv1(j)=dpsv(j)*c1e3/(one+dpsv(j))
11563   300 continue
11564       nwri=nwr(3)
11565       if(nwri.eq.0) nwri=numl+numlr+1
11566       if(idp.eq.0.or.ition.eq.0) then
11567         call thck4d(nthinerr)
11568       else
11569         hsy(3)=c1m3*hsy(3)*ition
11570         do 310 jj=1,nele
11571           if(kz(jj).eq.12) hsyc(jj)=c1m3*hsyc(jj)*itionc(jj)
11572   310   continue
11573         if(abs(phas).ge.pieni) then
11574           call thck6dua(nthinerr)
11575         else
11576           call thck6d(nthinerr)
11577         endif
11578       endif
11579       return
11580       end
11581       subroutine thck4d(nthinerr)
11582 !-----------------------------------------------------------------------
11583 !
11584 !  TRACK THICK LENS 4D
11585 !
11586 !
11587 !  F. SCHMIDT
11588 !-----------------------------------------------------------------------
11589       implicit none
11590       integer i,idz1,idz2,irrtr,ix,j,k,kpz,n,nmz,nthinerr
11591       double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
11592      &crxb,crzb,dpsv3,pux,puxve,puzve,r0,r2b,rb,rho2b,rkb,tkb,xbb,xlvj, &
11593      &xrb,yv1j,yv2j,zbb,zlvj,zrb
11594       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
11595      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
11596      &nrco,ntr,nzfz
11597       parameter(npart = 64,nmac = 1)
11598       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
11599      &nzfz = 300000,mmul = 11)
11600       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
11601      &nema = 15)
11602       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
11603       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
11604       parameter(nmon1 = 600,ncor1 = 600)
11605       parameter(ntr = 20,nbb = 160)
11606       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
11607       double precision e0fo,e0o,xv1j,xv2j
11608       double precision acdipamp, qd, acphase, acdipamp2,                &
11609      &acdipamp1
11610       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
11611       logical llost
11612       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
11613      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
11614      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
11615      &one,pieni,pmae,pmap,three,two,zero
11616       parameter(pieni = 1d-38)
11617       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
11618       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
11619       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
11620       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
11621       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
11622      &1.0d16)
11623       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
11624       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
11625       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
11626       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
11627       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
11628       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
11629       parameter(pmap = 938.271998d0,pmae = .510998902d0)
11630       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
11631       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
11632      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
11633      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
11634      &imc,imtr,iorg,iout,                                               &
11635      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
11636      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
11637      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
11638      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
11639      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
11640      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
11641      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
11642      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
11643      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
11644       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
11645      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
11646      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
11647      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
11648      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
11649      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
11650      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
11651      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
11652      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
11653      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
11654      &acdipph
11655       real hmal
11656       character*16 bez,bezb,bezr,erbez,bezl
11657       character*80 toptit,sixtit,commen
11658       common/erro/ierro,erbez
11659       common/kons/pi,pi2,pisqrt,rad
11660       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
11661       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
11662       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
11663       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
11664       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
11665       common/syos2/rvf(mpa)
11666       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
11667      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
11668       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
11669      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
11670      &iicav,itionc(nele),ition,idp,ncy,ixcav
11671       common/corcom/dpscor,sigcor,icode,idam,its6d
11672       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
11673      &bka(nele,mmul),aka(nele,mmul)
11674       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
11675       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
11676       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
11677      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
11678       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
11679       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
11680      &iout
11681       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
11682       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
11683      &ntco,eui,euii,nlin,bezl(nele)
11684       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
11685      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
11686      &ncororb(nele)
11687       common/apert/apx(nele),apz(nele),ape(3,nele)
11688       common/clos/sigma0(2),iclo,ncorru,ncorrep
11689       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
11690      &ratioe(nele),iratioe(nele),icoe
11691       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
11692       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
11693       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
11694       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
11695       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
11696      &nstart,nstop,iskip,iconv,imad
11697       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
11698       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
11699       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
11700       common/ripp2/nrturn
11701       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
11702       common/pawc/hmal(nplo)
11703       common/tit/sixtit,commen,ithick
11704       common/co6d/clo6(3),clop6(3)
11705       common/dkic/dki(nele,3)
11706       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
11707      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
11708      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
11709      &nbeam,ibbc,ibeco,ibtyp,lhc
11710       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
11711       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
11712       common/wireco/ wirel(nele)
11713       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
11714      &nturn3(nele), nturn4(nele)
11715       integer idz,itra
11716       double precision al,as,chi0,chid,dp1,dps,exz,sigm
11717       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
11718      &dps(mpa),idz(2)
11719       common/anf/chi0,chid,exz(2,6),dp1,itra
11720       integer ichrom,is
11721       double precision alf0,amp,bet0,clo,clop,cro,x,y
11722       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
11723       common/chrom/cro(2),is(2),ichrom
11724       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
11725      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
11726       double precision dpmax,preda,weig1,weig2
11727       character*16 coel
11728       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
11729       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
11730       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
11731      &coel(10)
11732       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
11733      &zsi
11734       real tlim,time0,time1
11735       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
11736      &aai(nblz,mmul),bbi(nblz,mmul)
11737       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
11738       common/damp/damp,ampt
11739       common/ttime/tlim,time0,time1
11740       double precision tasm
11741       common/tasm/tasm(6,6)
11742       integer iv,ixv,nlostp,nms,numxv
11743       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
11744      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
11745      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
11746      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
11747      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
11748      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
11749      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
11750      &zsiv,zsv
11751       logical pstop
11752       common/main1/                                                     &
11753      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
11754      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
11755      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
11756      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
11757      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
11758      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
11759      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
11760      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
11761       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
11762      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
11763      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
11764      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
11765      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
11766      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
11767      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
11768      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
11769      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
11770       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
11771      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
11772      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
11773      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
11774       integer numx
11775       double precision e0f
11776       common/main4/ e0f,numx
11777       integer ktrack,nwri
11778       double precision dpsv1,strack,strackc,stracks
11779       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
11780      &stracks(nblz),dpsv1(npart),nwri
11781       double precision cc,xlim,ylim
11782       parameter(cc = 1.12837916709551d0)
11783       parameter(xlim = 5.33d0)
11784       parameter(ylim = 4.29d0)
11785       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
11786      &r2b(npart),rb(npart),rkb(npart),                                  &
11787      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
11788      &crzb(npart),cbxb(npart),cbzb(npart)
11789       dimension dpsv3(npart)
11790       save
11791 !-----------------------------------------------------------------------
11792       nthinerr=0
11793       idz1=idz(1)
11794       idz2=idz(2)
11795       do 490 n=1,numl
11796           numx=n-1
11797           if(irip.eq.1) call ripple(n)
11798           if(mod(numx,nwri).eq.0) call writebin(nthinerr)
11799           if(nthinerr.ne.0) return
11800           do 480 i=1,iu
11801             if(ktrack(i).eq.1) then
11802               ix=ic(i)
11803             else
11804               ix=ic(i)-nblo
11805             endif
11806           if(i.eq.1103) then
11807           endif
11808 !----------count=43
11809             goto(20,480,740,480,480,480,480,480,480,480,40,60,80,100,   &
11810      &120,140,160,180,200,220,270,290,310,330,350,370,390,410,          &
11811      &430,450,470,240,500,520,540,560,580,600,620,640,680,700           &
11812      &,720,480,748,480,480,480,480,480,745,746),ktrack(i)
11813             goto 480
11814    20       do 30 j=1,napx
11815               puxve=xv(1,j)
11816               puzve=yv(1,j)
11817               xv(1,j)=bl1v(1,1,j,ix)*puxve+bl1v(2,1,j,ix)*puzve+ idz1   &
11818      &*bl1v(5,1,j,ix)*dpsv(j)*c1e3
11819               yv(1,j)=bl1v(3,1,j,ix)*puxve+bl1v(4,1,j,ix)*puzve+ idz1   &
11820      &*bl1v(6,1,j,ix)*dpsv(j)*c1e3
11821               puxve=xv(2,j)
11822               puzve=yv(2,j)
11823               xv(2,j)=bl1v(1,2,j,ix)*puxve+bl1v(2,2,j,ix)*puzve+ idz2   &
11824      &*bl1v(5,2,j,ix)*dpsv(j)*c1e3
11825               yv(2,j)=bl1v(3,2,j,ix)*puxve+bl1v(4,2,j,ix)*puzve+ idz2   &
11826      &*bl1v(6,2,j,ix)*dpsv(j)*c1e3
11827    30       continue
11828             goto 480
11829 !--HORIZONTAL DIPOLE
11830    40       do 50 j=1,napx
11831             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
11832             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
11833    50       continue
11834             goto 470
11835 !--NORMAL QUADRUPOLE
11836    60       do 70 j=1,napx
11837             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11838      &(xv(2,j)-zsiv(1,i))*tilts(i)
11839             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11840      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11841             crkve=xlv(j)
11842             cikve=zlv(j)
11843             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11844      &stracks(i)*cikve)
11845             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11846      &stracks(i)*crkve)
11847    70       continue
11848             goto 470
11849 !--NORMAL SEXTUPOLE
11850    80       do 90 j=1,napx
11851             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11852      &(xv(2,j)-zsiv(1,i))*tilts(i)
11853             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11854      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11855             crkve=xlv(j)
11856             cikve=zlv(j)
11857            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11858            cikve=crkve*zlv(j)+cikve*xlv(j)
11859            crkve=crkveuk
11860             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11861      &stracks(i)*cikve)
11862             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11863      &stracks(i)*crkve)
11864    90       continue
11865             goto 470
11866 !--NORMAL OCTUPOLE
11867   100       do 110 j=1,napx
11868             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11869      &(xv(2,j)-zsiv(1,i))*tilts(i)
11870             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11871      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11872             crkve=xlv(j)
11873             cikve=zlv(j)
11874            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11875            cikve=crkve*zlv(j)+cikve*xlv(j)
11876            crkve=crkveuk
11877            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11878            cikve=crkve*zlv(j)+cikve*xlv(j)
11879            crkve=crkveuk
11880             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11881      &stracks(i)*cikve)
11882             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11883      &stracks(i)*crkve)
11884   110       continue
11885             goto 470
11886 !--NORMAL DECAPOLE
11887   120       do 130 j=1,napx
11888             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11889      &(xv(2,j)-zsiv(1,i))*tilts(i)
11890             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11891      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11892             crkve=xlv(j)
11893             cikve=zlv(j)
11894            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11895            cikve=crkve*zlv(j)+cikve*xlv(j)
11896            crkve=crkveuk
11897            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11898            cikve=crkve*zlv(j)+cikve*xlv(j)
11899            crkve=crkveuk
11900            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11901            cikve=crkve*zlv(j)+cikve*xlv(j)
11902            crkve=crkveuk
11903             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11904      &stracks(i)*cikve)
11905             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11906      &stracks(i)*crkve)
11907   130       continue
11908             goto 470
11909 !--NORMAL DODECAPOLE
11910   140       do 150 j=1,napx
11911             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11912      &(xv(2,j)-zsiv(1,i))*tilts(i)
11913             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11914      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11915             crkve=xlv(j)
11916             cikve=zlv(j)
11917            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11918            cikve=crkve*zlv(j)+cikve*xlv(j)
11919            crkve=crkveuk
11920            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11921            cikve=crkve*zlv(j)+cikve*xlv(j)
11922            crkve=crkveuk
11923            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11924            cikve=crkve*zlv(j)+cikve*xlv(j)
11925            crkve=crkveuk
11926            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11927            cikve=crkve*zlv(j)+cikve*xlv(j)
11928            crkve=crkveuk
11929             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11930      &stracks(i)*cikve)
11931             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11932      &stracks(i)*crkve)
11933   150       continue
11934             goto 470
11935 !--NORMAL 14-POLE
11936   160       do 170 j=1,napx
11937             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11938      &(xv(2,j)-zsiv(1,i))*tilts(i)
11939             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11940      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11941             crkve=xlv(j)
11942             cikve=zlv(j)
11943            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11944            cikve=crkve*zlv(j)+cikve*xlv(j)
11945            crkve=crkveuk
11946            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11947            cikve=crkve*zlv(j)+cikve*xlv(j)
11948            crkve=crkveuk
11949            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11950            cikve=crkve*zlv(j)+cikve*xlv(j)
11951            crkve=crkveuk
11952            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11953            cikve=crkve*zlv(j)+cikve*xlv(j)
11954            crkve=crkveuk
11955            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11956            cikve=crkve*zlv(j)+cikve*xlv(j)
11957            crkve=crkveuk
11958             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11959      &stracks(i)*cikve)
11960             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11961      &stracks(i)*crkve)
11962   170       continue
11963             goto 470
11964 !--NORMAL 16-POLE
11965   180       do 190 j=1,napx
11966             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11967      &(xv(2,j)-zsiv(1,i))*tilts(i)
11968             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
11969      &(xv(2,j)-zsiv(1,i))*tiltc(i)
11970             crkve=xlv(j)
11971             cikve=zlv(j)
11972            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11973            cikve=crkve*zlv(j)+cikve*xlv(j)
11974            crkve=crkveuk
11975            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11976            cikve=crkve*zlv(j)+cikve*xlv(j)
11977            crkve=crkveuk
11978            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11979            cikve=crkve*zlv(j)+cikve*xlv(j)
11980            crkve=crkveuk
11981            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11982            cikve=crkve*zlv(j)+cikve*xlv(j)
11983            crkve=crkveuk
11984            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11985            cikve=crkve*zlv(j)+cikve*xlv(j)
11986            crkve=crkveuk
11987            crkveuk=crkve*xlv(j)-cikve*zlv(j)
11988            cikve=crkve*zlv(j)+cikve*xlv(j)
11989            crkve=crkveuk
11990             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
11991      &stracks(i)*cikve)
11992             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
11993      &stracks(i)*crkve)
11994   190       continue
11995             goto 470
11996 !--NORMAL 18-POLE
11997   200       do 210 j=1,napx
11998             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
11999      &(xv(2,j)-zsiv(1,i))*tilts(i)
12000             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12001      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12002             crkve=xlv(j)
12003             cikve=zlv(j)
12004            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12005            cikve=crkve*zlv(j)+cikve*xlv(j)
12006            crkve=crkveuk
12007            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12008            cikve=crkve*zlv(j)+cikve*xlv(j)
12009            crkve=crkveuk
12010            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12011            cikve=crkve*zlv(j)+cikve*xlv(j)
12012            crkve=crkveuk
12013            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12014            cikve=crkve*zlv(j)+cikve*xlv(j)
12015            crkve=crkveuk
12016            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12017            cikve=crkve*zlv(j)+cikve*xlv(j)
12018            crkve=crkveuk
12019            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12020            cikve=crkve*zlv(j)+cikve*xlv(j)
12021            crkve=crkveuk
12022            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12023            cikve=crkve*zlv(j)+cikve*xlv(j)
12024            crkve=crkveuk
12025             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
12026      &stracks(i)*cikve)
12027             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
12028      &stracks(i)*crkve)
12029   210       continue
12030             goto 470
12031 !--NORMAL 20-POLE
12032   220       do 230 j=1,napx
12033             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12034      &(xv(2,j)-zsiv(1,i))*tilts(i)
12035             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12036      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12037             crkve=xlv(j)
12038             cikve=zlv(j)
12039            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12040            cikve=crkve*zlv(j)+cikve*xlv(j)
12041            crkve=crkveuk
12042            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12043            cikve=crkve*zlv(j)+cikve*xlv(j)
12044            crkve=crkveuk
12045            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12046            cikve=crkve*zlv(j)+cikve*xlv(j)
12047            crkve=crkveuk
12048            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12049            cikve=crkve*zlv(j)+cikve*xlv(j)
12050            crkve=crkveuk
12051            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12052            cikve=crkve*zlv(j)+cikve*xlv(j)
12053            crkve=crkveuk
12054            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12055            cikve=crkve*zlv(j)+cikve*xlv(j)
12056            crkve=crkveuk
12057            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12058            cikve=crkve*zlv(j)+cikve*xlv(j)
12059            crkve=crkveuk
12060            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12061            cikve=crkve*zlv(j)+cikve*xlv(j)
12062            crkve=crkveuk
12063             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
12064      &stracks(i)*cikve)
12065             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
12066      &stracks(i)*crkve)
12067   230       continue
12068             goto 470
12069   500     continue
12070           do 510 j=1,napx
12071             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
12072      &(xv(2,j)-zsiv(1,i))*tilts(i)
12073             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
12074      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12075             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
12076      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
12077      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12078             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
12079      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
12080      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12081   510     continue
12082           goto 470
12083   520     continue
12084           do 530 j=1,napx
12085             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
12086      &(xv(2,j)-zsiv(1,i))*tilts(i)
12087             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
12088      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12089             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
12090      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
12091      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12092             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
12093      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
12094      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12095   530     continue
12096           goto 240
12097   540     continue
12098           do 550 j=1,napx
12099             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
12100      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12101             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
12102      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12103   550     continue
12104           goto 470
12105   560     continue
12106           do 570 j=1,napx
12107             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
12108      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
12109             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
12110      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
12111   570     continue
12112           goto 240
12113   580     continue
12114           do 590 j=1,napx
12115             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
12116      &(xv(2,j)-zsiv(1,i))*tilts(i)
12117             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
12118      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12119             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
12120      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
12121      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12122             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
12123      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
12124      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12125   590     continue
12126           goto 470
12127   600     continue
12128           do 610 j=1,napx
12129             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
12130      &(xv(2,j)-zsiv(1,i))*tilts(i)
12131             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
12132      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12133             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
12134      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
12135      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12136             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
12137      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
12138      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12139   610     continue
12140           goto 240
12141   620     continue
12142           do 630 j=1,napx
12143             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
12144      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12145             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
12146      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12147   630     continue
12148           goto 470
12149   640     continue
12150           do 650 j=1,napx
12151             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
12152      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
12153             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
12154      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
12155   650     continue
12156   240       r0=ek(ix)
12157             nmz=nmu(ix)
12158           if(nmz.ge.2) then
12159             do 260 j=1,napx
12160             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
12161      &(xv(2,j)-zsiv(1,i))*tilts(i)
12162             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
12163      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12164               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
12165               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
12166               crkve=xlvj
12167               cikve=zlvj
12168                 do 250 k=3,nmz
12169                   crkveuk=crkve*xlvj-cikve*zlvj
12170                   cikve=crkve*zlvj+cikve*xlvj
12171                   crkve=crkveuk
12172                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
12173                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
12174   250           continue
12175               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
12176               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
12177   260       continue
12178           else
12179             do 265 j=1,napx
12180               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
12181      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
12182               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
12183      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
12184   265       continue
12185           endif
12186             goto 470
12187 !--SKEW ELEMENTS
12188 !--VERTICAL DIPOLE
12189   270       do 280 j=1,napx
12190             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
12191             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
12192   280       continue
12193             goto 470
12194 !--SKEW QUADRUPOLE
12195   290       do 300 j=1,napx
12196             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12197      &(xv(2,j)-zsiv(1,i))*tilts(i)
12198             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12199      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12200             crkve=xlv(j)
12201             cikve=zlv(j)
12202             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12203      &stracks(i)*crkve)
12204             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12205      &stracks(i)*cikve)
12206   300       continue
12207             goto 470
12208 !--SKEW SEXTUPOLE
12209   310       do 320 j=1,napx
12210             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12211      &(xv(2,j)-zsiv(1,i))*tilts(i)
12212             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12213      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12214             crkve=xlv(j)
12215             cikve=zlv(j)
12216            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12217            cikve=crkve*zlv(j)+cikve*xlv(j)
12218            crkve=crkveuk
12219             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12220      &stracks(i)*crkve)
12221             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12222      &stracks(i)*cikve)
12223   320       continue
12224             goto 470
12225 !--SKEW OCTUPOLE
12226   330       do 340 j=1,napx
12227             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12228      &(xv(2,j)-zsiv(1,i))*tilts(i)
12229             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12230      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12231             crkve=xlv(j)
12232             cikve=zlv(j)
12233            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12234            cikve=crkve*zlv(j)+cikve*xlv(j)
12235            crkve=crkveuk
12236            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12237            cikve=crkve*zlv(j)+cikve*xlv(j)
12238            crkve=crkveuk
12239             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12240      &stracks(i)*crkve)
12241             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12242      &stracks(i)*cikve)
12243   340       continue
12244             goto 470
12245 !--SKEW DECAPOLE
12246   350       do 360 j=1,napx
12247             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12248      &(xv(2,j)-zsiv(1,i))*tilts(i)
12249             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12250      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12251             crkve=xlv(j)
12252             cikve=zlv(j)
12253            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12254            cikve=crkve*zlv(j)+cikve*xlv(j)
12255            crkve=crkveuk
12256            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12257            cikve=crkve*zlv(j)+cikve*xlv(j)
12258            crkve=crkveuk
12259            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12260            cikve=crkve*zlv(j)+cikve*xlv(j)
12261            crkve=crkveuk
12262             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12263      &stracks(i)*crkve)
12264             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12265      &stracks(i)*cikve)
12266   360       continue
12267             goto 470
12268 !--SKEW DODECAPOLE
12269   370       do 380 j=1,napx
12270             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12271      &(xv(2,j)-zsiv(1,i))*tilts(i)
12272             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12273      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12274             crkve=xlv(j)
12275             cikve=zlv(j)
12276            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12277            cikve=crkve*zlv(j)+cikve*xlv(j)
12278            crkve=crkveuk
12279            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12280            cikve=crkve*zlv(j)+cikve*xlv(j)
12281            crkve=crkveuk
12282            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12283            cikve=crkve*zlv(j)+cikve*xlv(j)
12284            crkve=crkveuk
12285            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12286            cikve=crkve*zlv(j)+cikve*xlv(j)
12287            crkve=crkveuk
12288             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12289      &stracks(i)*crkve)
12290             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12291      &stracks(i)*cikve)
12292   380       continue
12293             goto 470
12294 !--SKEW 14-POLE
12295   390       do 400 j=1,napx
12296             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12297      &(xv(2,j)-zsiv(1,i))*tilts(i)
12298             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12299      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12300             crkve=xlv(j)
12301             cikve=zlv(j)
12302            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12303            cikve=crkve*zlv(j)+cikve*xlv(j)
12304            crkve=crkveuk
12305            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12306            cikve=crkve*zlv(j)+cikve*xlv(j)
12307            crkve=crkveuk
12308            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12309            cikve=crkve*zlv(j)+cikve*xlv(j)
12310            crkve=crkveuk
12311            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12312            cikve=crkve*zlv(j)+cikve*xlv(j)
12313            crkve=crkveuk
12314            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12315            cikve=crkve*zlv(j)+cikve*xlv(j)
12316            crkve=crkveuk
12317             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12318      &stracks(i)*crkve)
12319             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12320      &stracks(i)*cikve)
12321   400       continue
12322             goto 470
12323 !--SKEW 16-POLE
12324   410       do 420 j=1,napx
12325             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12326      &(xv(2,j)-zsiv(1,i))*tilts(i)
12327             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12328      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12329             crkve=xlv(j)
12330             cikve=zlv(j)
12331            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12332            cikve=crkve*zlv(j)+cikve*xlv(j)
12333            crkve=crkveuk
12334            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12335            cikve=crkve*zlv(j)+cikve*xlv(j)
12336            crkve=crkveuk
12337            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12338            cikve=crkve*zlv(j)+cikve*xlv(j)
12339            crkve=crkveuk
12340            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12341            cikve=crkve*zlv(j)+cikve*xlv(j)
12342            crkve=crkveuk
12343            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12344            cikve=crkve*zlv(j)+cikve*xlv(j)
12345            crkve=crkveuk
12346            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12347            cikve=crkve*zlv(j)+cikve*xlv(j)
12348            crkve=crkveuk
12349             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12350      &stracks(i)*crkve)
12351             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12352      &stracks(i)*cikve)
12353   420       continue
12354             goto 470
12355 !--SKEW 18-POLE
12356   430       do 440 j=1,napx
12357             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12358      &(xv(2,j)-zsiv(1,i))*tilts(i)
12359             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12360      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12361             crkve=xlv(j)
12362             cikve=zlv(j)
12363            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12364            cikve=crkve*zlv(j)+cikve*xlv(j)
12365            crkve=crkveuk
12366            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12367            cikve=crkve*zlv(j)+cikve*xlv(j)
12368            crkve=crkveuk
12369            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12370            cikve=crkve*zlv(j)+cikve*xlv(j)
12371            crkve=crkveuk
12372            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12373            cikve=crkve*zlv(j)+cikve*xlv(j)
12374            crkve=crkveuk
12375            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12376            cikve=crkve*zlv(j)+cikve*xlv(j)
12377            crkve=crkveuk
12378            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12379            cikve=crkve*zlv(j)+cikve*xlv(j)
12380            crkve=crkveuk
12381            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12382            cikve=crkve*zlv(j)+cikve*xlv(j)
12383            crkve=crkveuk
12384             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12385      &stracks(i)*crkve)
12386             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12387      &stracks(i)*cikve)
12388   440       continue
12389             goto 470
12390 !--SKEW 20-POLE
12391   450       do 460 j=1,napx
12392             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
12393      &(xv(2,j)-zsiv(1,i))*tilts(i)
12394             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
12395      &(xv(2,j)-zsiv(1,i))*tiltc(i)
12396             crkve=xlv(j)
12397             cikve=zlv(j)
12398            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12399            cikve=crkve*zlv(j)+cikve*xlv(j)
12400            crkve=crkveuk
12401            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12402            cikve=crkve*zlv(j)+cikve*xlv(j)
12403            crkve=crkveuk
12404            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12405            cikve=crkve*zlv(j)+cikve*xlv(j)
12406            crkve=crkveuk
12407            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12408            cikve=crkve*zlv(j)+cikve*xlv(j)
12409            crkve=crkveuk
12410            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12411            cikve=crkve*zlv(j)+cikve*xlv(j)
12412            crkve=crkveuk
12413            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12414            cikve=crkve*zlv(j)+cikve*xlv(j)
12415            crkve=crkveuk
12416            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12417            cikve=crkve*zlv(j)+cikve*xlv(j)
12418            crkve=crkveuk
12419            crkveuk=crkve*xlv(j)-cikve*zlv(j)
12420            cikve=crkve*zlv(j)+cikve*xlv(j)
12421            crkve=crkveuk
12422             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
12423      &stracks(i)*crkve)
12424             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
12425      &stracks(i)*cikve)
12426   460       continue
12427           goto 470
12428   680     continue
12429           do 690 j=1,napx
12430               if(ibbc.eq.0) then
12431                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12432                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12433               else
12434                 crkveb(j)=                                              &
12435      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
12436      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12437                 cikveb(j)=                                              &
12438      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
12439      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12440               endif
12441             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
12442             if(rho2b(j).le.pieni)                                       &
12443      &goto 690
12444             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
12445             if(ibbc.eq.0) then
12446               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
12447      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
12448               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
12449      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
12450             else
12451               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
12452      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
12453      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
12454      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12455               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12456               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
12457      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
12458      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
12459      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12460               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12461             endif
12462   690     continue
12463           goto 470
12464   700     continue
12465           if(ibtyp.eq.0) then
12466             do j=1,napx
12467               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
12468               rb(j)=sqrt(r2b(j))
12469               rkb(j)=strack(i)*pisqrt/rb(j)
12470               if(ibbc.eq.0) then
12471                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12472                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12473               else
12474                 crkveb(j)=                                              &
12475      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
12476      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12477                 cikveb(j)=                                              &
12478      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
12479      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12480               endif
12481               xrb(j)=abs(crkveb(j))/rb(j)
12482               zrb(j)=abs(cikveb(j))/rb(j)
12483               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
12484               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
12485      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12486               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12487               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12488               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
12489               if(ibbc.eq.0) then
12490                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12491      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12492                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12493      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12494               else
12495                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12496      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12497      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12498      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12499                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12500                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12501      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12502      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12503      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12504                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12505               endif
12506             enddo
12507           else if(ibtyp.eq.1) then
12508             do j=1,napx
12509               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
12510               rb(j)=sqrt(r2b(j))
12511               rkb(j)=strack(i)*pisqrt/rb(j)
12512               if(ibbc.eq.0) then
12513                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12514                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12515               else
12516                 crkveb(j)=                                              &
12517      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
12518      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12519                 cikveb(j)=                                              &
12520      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
12521      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12522               endif
12523               xrb(j)=abs(crkveb(j))/rb(j)
12524               zrb(j)=abs(cikveb(j))/rb(j)
12525               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
12526      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12527               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12528               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12529             enddo
12530             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
12531             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
12532             do j=1,napx
12533               if(ibbc.eq.0) then
12534                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12535      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12536                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12537      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12538               else
12539                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12540      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12541      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12542      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12543                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12544                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12545      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12546      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12547      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12548                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12549               endif
12550             enddo
12551           endif
12552           goto 470
12553   720     continue
12554           if(ibtyp.eq.0) then
12555             do j=1,napx
12556               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
12557               rb(j)=sqrt(r2b(j))
12558               rkb(j)=strack(i)*pisqrt/rb(j)
12559               if(ibbc.eq.0) then
12560                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12561                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12562               else
12563                 crkveb(j)=                                              &
12564      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
12565      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12566                 cikveb(j)=                                              &
12567      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
12568      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12569               endif
12570               xrb(j)=abs(crkveb(j))/rb(j)
12571               zrb(j)=abs(cikveb(j))/rb(j)
12572               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
12573               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
12574      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12575               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12576               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12577               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
12578               if(ibbc.eq.0) then
12579                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12580      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12581                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12582      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12583               else
12584                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12585      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12586      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12587      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12588                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12589                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12590      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12591      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12592      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12593                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12594               endif
12595             enddo
12596           else if(ibtyp.eq.1) then
12597             do j=1,napx
12598               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
12599               rb(j)=sqrt(r2b(j))
12600               rkb(j)=strack(i)*pisqrt/rb(j)
12601               if(ibbc.eq.0) then
12602                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
12603                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
12604               else
12605                 crkveb(j)=                                              &
12606      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
12607      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
12608                 cikveb(j)=                                              &
12609      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
12610      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
12611               endif
12612               xrb(j)=abs(crkveb(j))/rb(j)
12613               zrb(j)=abs(cikveb(j))/rb(j)
12614               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
12615      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
12616               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
12617               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
12618             enddo
12619             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
12620             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
12621             do j=1,napx
12622               if(ibbc.eq.0) then
12623                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
12624      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
12625                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
12626      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
12627               else
12628                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12629      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12630      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12631      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
12632                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
12633                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
12634      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
12635      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
12636      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
12637                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
12638               endif
12639             enddo
12640           endif
12641           goto 470
12642   740     continue
12643           irrtr=imtr(ix)
12644           do j=1,napx
12645             pux=xv(1,j)
12646             dpsv3(j)=dpsv(j)*c1e3
12647             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
12648      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
12649             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
12650      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
12651             pux=xv(2,j)
12652             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
12653      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
12654             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
12655      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
12656           enddo
12657  
12658 !----------------------------------------------------------------------
12659  
12660 ! Wire.
12661  
12662           goto 470
12663   745     continue
12664           xory=1
12665           nfree=nturn1(ix)
12666          if(n.gt.nfree) then
12667           nac=n-nfree
12668           pi=4d0*atan(1d0)
12669 !---------ACdipAmp input in Tesla*meter converted to KeV/c
12670 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
12671           acdipamp=ed(ix)*clight*1.0d-3
12672 !---------Qd input in tune units
12673           qd=ek(ix)
12674 !---------ACphase input in radians
12675           acphase=acdipph(ix)
12676           nramp1=nturn2(ix)
12677           nplato=nturn3(ix)
12678           nramp2=nturn4(ix)
12679           do j=1,napx
12680       if (xory.eq.1) then
12681         acdipamp2=acdipamp*tilts(i)
12682         acdipamp1=acdipamp*tiltc(i)
12683       else
12684         acdipamp2=acdipamp*tiltc(i)
12685         acdipamp1=-acdipamp*tilts(i)
12686       endif
12687               if(nramp1.gt.nac) then
12688                 yv(1,j)=yv(1,j)+acdipamp1*                              &
12689      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12690                 yv(2,j)=yv(2,j)+acdipamp2*                              &
12691      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12692               endif
12693               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
12694                 yv(1,j)=yv(1,j)+acdipamp1*                              &
12695      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12696                 yv(2,j)=yv(2,j)+acdipamp2*                              &
12697      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12698               endif
12699               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
12700      &nac)then
12701               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
12702      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12703               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
12704      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12705               endif
12706       enddo
12707       endif
12708           goto 470
12709   746     continue
12710           xory=2
12711           nfree=nturn1(ix)
12712          if(n.gt.nfree) then
12713           nac=n-nfree
12714           pi=4d0*atan(1d0)
12715 !---------ACdipAmp input in Tesla*meter converted to KeV/c
12716 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
12717           acdipamp=ed(ix)*clight*1.0d-3
12718 !---------Qd input in tune units
12719           qd=ek(ix)
12720 !---------ACphase input in radians
12721           acphase=acdipph(ix)
12722           nramp1=nturn2(ix)
12723           nplato=nturn3(ix)
12724           nramp2=nturn4(ix)
12725           do j=1,napx
12726       if (xory.eq.1) then
12727         acdipamp2=acdipamp*tilts(i)
12728         acdipamp1=acdipamp*tiltc(i)
12729       else
12730         acdipamp2=acdipamp*tiltc(i)
12731         acdipamp1=-acdipamp*tilts(i)
12732       endif
12733               if(nramp1.gt.nac) then
12734                 yv(1,j)=yv(1,j)+acdipamp1*                              &
12735      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12736                 yv(2,j)=yv(2,j)+acdipamp2*                              &
12737      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
12738               endif
12739               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
12740                 yv(1,j)=yv(1,j)+acdipamp1*                              &
12741      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12742                 yv(2,j)=yv(2,j)+acdipamp2*                              &
12743      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
12744               endif
12745               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
12746      &nac)then
12747               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
12748      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12749               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
12750      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
12751               endif
12752       enddo
12753       endif
12754           goto 470
12755  
12756 !----------------------------
12757  
12758 ! Wire.
12759  
12760   748     continue
12761 !     magnetic rigidity
12762       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
12763  
12764       ix = ixcav
12765       tx = xrms(ix)
12766       ty = zrms(ix)
12767       dx = xpl(ix)
12768       dy = zpl(ix)
12769       embl = ek(ix)
12770       l = wirel(ix)
12771       cur = ed(ix)
12772  
12773       leff = embl/cos(tx)/cos(ty)
12774       rx = dx *cos(tx)-embl*sin(tx)/2
12775       lin= dx *sin(tx)+embl*cos(tx)/2
12776       ry = dy *cos(ty)-lin *sin(ty)
12777       lin= lin*cos(ty)+dy  *sin(ty)
12778  
12779       do 750 j=1, napx
12780  
12781       xv(1,j) = xv(1,j) * c1m3
12782       xv(2,j) = xv(2,j) * c1m3
12783       yv(1,j) = yv(1,j) * c1m3
12784       yv(2,j) = yv(2,j) * c1m3
12785  
12786 !      print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
12787 !     &yv(2,j)
12788  
12789 !     call drift(-embl/2)
12790  
12791       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12792      &yv(2,j)**2)
12793       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12794      &yv(2,j)**2)
12795  
12796 !     call tilt(tx,ty)
12797  
12798       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
12799      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
12800      &yv(2,j)**2))-tx)
12801       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
12802      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
12803       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
12804      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
12805  
12806       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
12807      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
12808      &yv(2,j)**2))-ty)
12809       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
12810      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
12811       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
12812      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
12813  
12814 !     call drift(lin)
12815  
12816       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
12817      &yv(2,j)**2)
12818       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
12819      &yv(2,j)**2)
12820  
12821 !      call kick(l,cur,lin,rx,ry,chi)
12822  
12823       xi = xv(1,j)-rx
12824       yi = xv(2,j)-ry
12825       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
12826      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
12827      &xi**2+yi**2))
12828 !GRD FOR CONSISTENSY
12829 !      yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)*                  &
12830       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
12831      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
12832      &xi**2+yi**2))
12833  
12834 !     call drift(leff-lin)
12835  
12836       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
12837      &yv(1,j)**2-yv(2,j)**2)
12838       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
12839      &yv(1,j)**2-yv(2,j)**2)
12840  
12841 !     call invtilt(tx,ty)
12842  
12843       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
12844      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
12845      &yv(2,j)**2))+ty)
12846       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
12847      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
12848       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
12849      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
12850  
12851       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
12852      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
12853      &yv(2,j)**2))+tx)
12854       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
12855      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
12856       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
12857      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
12858  
12859 !     call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
12860  
12861       xv(1,j) = xv(1,j) + embl*tan(tx)
12862       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
12863  
12864 !     call drift(-embl/2)
12865  
12866       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12867      &yv(2,j)**2)
12868       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
12869      &yv(2,j)**2)
12870  
12871       xv(1,j) = xv(1,j) * c1e3
12872       xv(2,j) = xv(2,j) * c1e3
12873       yv(1,j) = yv(1,j) * c1e3
12874       yv(2,j) = yv(2,j) * c1e3
12875  
12876 !      print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
12877 !     &yv(2,j)
12878  
12879 !-----------------------------------------------------------------------
12880  
12881   750     continue
12882           goto 470
12883  
12884 !----------------------------
12885  
12886   470       continue
12887           llost=.false.
12888           do j=1,napx
12889              llost=llost.or.                                            &
12890      &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
12891           enddo
12892           if (llost) then
12893              kpz=abs(kp(ix))
12894              if(kpz.eq.2) then
12895                 call lostpar3(i,ix,nthinerr)
12896                 if(nthinerr.ne.0) return
12897              elseif(kpz.eq.3) then
12898                 call lostpar4(i,ix,nthinerr)
12899                 if(nthinerr.ne.0) return
12900              else
12901                 call lostpar2(i,ix,nthinerr)
12902                 if(nthinerr.ne.0) return
12903              endif
12904           endif
12905   480     continue
12906           call lostpart(nthinerr)
12907           if(nthinerr.ne.0) return
12908           if(ntwin.ne.2) call dist1
12909           if(mod(n,nwr(4)).eq.0) call write6(n)
12910   490 continue
12911       return
12912       end
12913       subroutine thck6d(nthinerr)
12914 !-----------------------------------------------------------------------
12915 !
12916 !  TRACK THICK LENS 6D
12917 !
12918 !
12919 !  F. SCHMIDT
12920 !-----------------------------------------------------------------------
12921       implicit none
12922       integer i,idz1,idz2,irrtr,ix,j,jb,jmel,jx,k,kpz,n,nmz,nthinerr
12923       double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
12924      &crxb,crzb,dpsv3,pux,puxve1,puxve2,puzve1,puzve2,r0,r2b,rb,rho2b,  &
12925      &rkb,tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
12926       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
12927      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
12928      &nrco,ntr,nzfz
12929       parameter(npart = 64,nmac = 1)
12930       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
12931      &nzfz = 300000,mmul = 11)
12932       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
12933      &nema = 15)
12934       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
12935       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
12936       parameter(nmon1 = 600,ncor1 = 600)
12937       parameter(ntr = 20,nbb = 160)
12938       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
12939       double precision e0fo,e0o,xv1j,xv2j
12940       double precision acdipamp, qd, acphase,acdipamp2,                 &
12941      &acdipamp1
12942       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
12943       logical llost
12944       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
12945      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
12946      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
12947      &one,pieni,pmae,pmap,three,two,zero
12948       parameter(pieni = 1d-38)
12949       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
12950       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
12951       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
12952       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
12953       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
12954      &1.0d16)
12955       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
12956       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
12957       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
12958       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
12959       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
12960       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
12961       parameter(pmap = 938.271998d0,pmae = .510998902d0)
12962       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
12963       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
12964      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
12965      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
12966      &imc,imtr,iorg,iout,                                               &
12967      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
12968      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
12969      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
12970      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
12971      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
12972      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
12973      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
12974      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
12975      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
12976       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
12977      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
12978      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
12979      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
12980      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
12981      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
12982      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
12983      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
12984      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
12985      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
12986      &acdipph
12987       real hmal
12988       character*16 bez,bezb,bezr,erbez,bezl
12989       character*80 toptit,sixtit,commen
12990       common/erro/ierro,erbez
12991       common/kons/pi,pi2,pisqrt,rad
12992       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
12993       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
12994       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
12995       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
12996       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
12997       common/syos2/rvf(mpa)
12998       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
12999      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
13000       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
13001      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
13002      &iicav,itionc(nele),ition,idp,ncy,ixcav
13003       common/corcom/dpscor,sigcor,icode,idam,its6d
13004       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
13005      &bka(nele,mmul),aka(nele,mmul)
13006       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
13007       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
13008       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
13009      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
13010       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
13011       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
13012      &iout
13013       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
13014       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
13015      &ntco,eui,euii,nlin,bezl(nele)
13016       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
13017      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
13018      &ncororb(nele)
13019       common/apert/apx(nele),apz(nele),ape(3,nele)
13020       common/clos/sigma0(2),iclo,ncorru,ncorrep
13021       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
13022      &ratioe(nele),iratioe(nele),icoe
13023       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
13024       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
13025       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
13026       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
13027       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
13028      &nstart,nstop,iskip,iconv,imad
13029       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
13030       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
13031       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
13032       common/ripp2/nrturn
13033       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
13034       common/pawc/hmal(nplo)
13035       common/tit/sixtit,commen,ithick
13036       common/co6d/clo6(3),clop6(3)
13037       common/dkic/dki(nele,3)
13038       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
13039      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
13040      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
13041      &nbeam,ibbc,ibeco,ibtyp,lhc
13042       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
13043       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
13044       common/wireco/ wirel(nele)
13045       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
13046      &nturn3(nele), nturn4(nele)
13047       integer idz,itra
13048       double precision al,as,chi0,chid,dp1,dps,exz,sigm
13049       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
13050      &dps(mpa),idz(2)
13051       common/anf/chi0,chid,exz(2,6),dp1,itra
13052       integer ichrom,is
13053       double precision alf0,amp,bet0,clo,clop,cro,x,y
13054       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
13055       common/chrom/cro(2),is(2),ichrom
13056       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
13057      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
13058       double precision dpmax,preda,weig1,weig2
13059       character*16 coel
13060       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
13061       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
13062       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
13063      &coel(10)
13064       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
13065      &zsi
13066       real tlim,time0,time1
13067       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
13068      &aai(nblz,mmul),bbi(nblz,mmul)
13069       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
13070       common/damp/damp,ampt
13071       common/ttime/tlim,time0,time1
13072       double precision tasm
13073       common/tasm/tasm(6,6)
13074       integer iv,ixv,nlostp,nms,numxv
13075       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
13076      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
13077      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
13078      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
13079      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
13080      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
13081      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
13082      &zsiv,zsv
13083       logical pstop
13084       common/main1/                                                     &
13085      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
13086      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
13087      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
13088      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
13089      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
13090      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
13091      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
13092      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
13093       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
13094      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
13095      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
13096      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
13097      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
13098      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
13099      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
13100      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
13101      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
13102       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
13103      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
13104      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
13105      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
13106       integer numx
13107       double precision e0f
13108       common/main4/ e0f,numx
13109       integer ktrack,nwri
13110       double precision dpsv1,strack,strackc,stracks
13111       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
13112      &stracks(nblz),dpsv1(npart),nwri
13113       double precision cc,xlim,ylim
13114       parameter(cc = 1.12837916709551d0)
13115       parameter(xlim = 5.33d0)
13116       parameter(ylim = 4.29d0)
13117       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
13118      &r2b(npart),rb(npart),rkb(npart),                                  &
13119      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
13120      &crzb(npart),cbxb(npart),cbzb(npart)
13121       dimension dpsv3(npart)
13122       save
13123 !-----------------------------------------------------------------------
13124       nthinerr=0
13125       idz1=idz(1)
13126       idz2=idz(2)
13127       do 510 n=1,numl
13128           numx=n-1
13129           if(irip.eq.1) call ripple(n)
13130           if(mod(numx,nwri).eq.0) call writebin(nthinerr)
13131           if(nthinerr.ne.0) return
13132           do 500 i=1,iu
13133             if(ktrack(i).eq.1) then
13134               ix=ic(i)
13135             else
13136               ix=ic(i)-nblo
13137             endif
13138 !----------count 44
13139             goto(20,40,740,500,500,500,500,500,500,500,60,80,100,120,   &
13140      &140,160,180,200,220,240,290,310,330,350,370,390,410,430,          &
13141      &450,470,490,260,520,540,560,580,600,620,640,660,680,700,720       &
13142      &,730,748,500,500,500,500,500,745,746),ktrack(i)
13143             goto 500
13144    20       jmel=mel(ix)
13145             do 30 jb=1,jmel
13146               jx=mtyp(ix,jb)
13147               do 30 j=1,napx
13148                 puxve1=xv(1,j)
13149                 puzve1=yv(1,j)
13150                 puxve2=xv(2,j)
13151                 puzve2=yv(2,j)
13152                 sigmv(j)=sigmv(j)+as(1,1,j,jx)+puxve1*(as(2,1,j,jx)+ as &
13153      &(4,1,j,jx)*puzve1+as(5,1,j,jx)*puxve1)+ puzve1*(as                &
13154      &(3,1,j,jx)+as(6,1,j,jx)*puzve1)                                   &
13155      &+as(1,2,j,jx)+puxve2*(as(2,2,j,jx)+ as                            &
13156      &(4,2,j,jx)*puzve2+as(5,2,j,jx)*puxve2)+ puzve2*(as                &
13157      &(3,2,j,jx)+as(6,2,j,jx)*puzve2)
13158                 xv(1,j)=al(1,1,j,jx)*puxve1+ al(2,1,j,jx)*puzve1+idz1*al&
13159      &(5,1,j,jx)
13160                 xv(2,j)=al(1,2,j,jx)*puxve2+ al(2,2,j,jx)*puzve2+idz2*al&
13161      &(5,2,j,jx)
13162                 yv(1,j)=al(3,1,j,jx)*puxve1+ al(4,1,j,jx)*puzve1+idz1*al&
13163      &(6,1,j,jx)
13164                 yv(2,j)=al(3,2,j,jx)*puxve2+ al(4,2,j,jx)*puzve2+idz2*al&
13165      &(6,2,j,jx)
13166    30       continue
13167             goto 500
13168    40       do 50 j=1,napx
13169               ejf0v(j)=ejfv(j)
13170               if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
13171               if(kz(ix).eq.12) then
13172                 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+             &
13173      &phasc(ix))
13174               else
13175                 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j))
13176               endif
13177               ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
13178               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
13179               dpsv(j)=(ejfv(j)-e0f)/e0f
13180               oidpsv(j)=one/(one+dpsv(j))
13181               dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
13182               yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
13183    50       yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
13184             if(n.eq.1) write(98,'(1p,6(2x,e25.18))')                    &
13185      &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),                &
13186      &j=1,napx)
13187             call synuthck
13188             goto 490
13189 !--HORIZONTAL DIPOLE
13190    60       do 70 j=1,napx
13191             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
13192             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
13193    70       continue
13194             goto 490
13195 !--NORMAL QUADRUPOLE
13196    80       do 90 j=1,napx
13197             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13198      &(xv(2,j)-zsiv(1,i))*tilts(i)
13199             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13200      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13201             crkve=xlv(j)
13202             cikve=zlv(j)
13203             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13204      &stracks(i)*cikve)
13205             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13206      &stracks(i)*crkve)
13207    90       continue
13208             goto 490
13209 !--NORMAL SEXTUPOLE
13210   100       do 110 j=1,napx
13211             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13212      &(xv(2,j)-zsiv(1,i))*tilts(i)
13213             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13214      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13215             crkve=xlv(j)
13216             cikve=zlv(j)
13217            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13218            cikve=crkve*zlv(j)+cikve*xlv(j)
13219            crkve=crkveuk
13220             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13221      &stracks(i)*cikve)
13222             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13223      &stracks(i)*crkve)
13224   110       continue
13225             goto 490
13226 !--NORMAL OCTUPOLE
13227   120       do 130 j=1,napx
13228             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13229      &(xv(2,j)-zsiv(1,i))*tilts(i)
13230             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13231      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13232             crkve=xlv(j)
13233             cikve=zlv(j)
13234            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13235            cikve=crkve*zlv(j)+cikve*xlv(j)
13236            crkve=crkveuk
13237            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13238            cikve=crkve*zlv(j)+cikve*xlv(j)
13239            crkve=crkveuk
13240             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13241      &stracks(i)*cikve)
13242             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13243      &stracks(i)*crkve)
13244   130       continue
13245             goto 490
13246 !--NORMAL DECAPOLE
13247   140       do 150 j=1,napx
13248             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13249      &(xv(2,j)-zsiv(1,i))*tilts(i)
13250             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13251      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13252             crkve=xlv(j)
13253             cikve=zlv(j)
13254            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13255            cikve=crkve*zlv(j)+cikve*xlv(j)
13256            crkve=crkveuk
13257            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13258            cikve=crkve*zlv(j)+cikve*xlv(j)
13259            crkve=crkveuk
13260            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13261            cikve=crkve*zlv(j)+cikve*xlv(j)
13262            crkve=crkveuk
13263             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13264      &stracks(i)*cikve)
13265             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13266      &stracks(i)*crkve)
13267   150       continue
13268             goto 490
13269 !--NORMAL DODECAPOLE
13270   160       do 170 j=1,napx
13271             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13272      &(xv(2,j)-zsiv(1,i))*tilts(i)
13273             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13274      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13275             crkve=xlv(j)
13276             cikve=zlv(j)
13277            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13278            cikve=crkve*zlv(j)+cikve*xlv(j)
13279            crkve=crkveuk
13280            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13281            cikve=crkve*zlv(j)+cikve*xlv(j)
13282            crkve=crkveuk
13283            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13284            cikve=crkve*zlv(j)+cikve*xlv(j)
13285            crkve=crkveuk
13286            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13287            cikve=crkve*zlv(j)+cikve*xlv(j)
13288            crkve=crkveuk
13289             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13290      &stracks(i)*cikve)
13291             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13292      &stracks(i)*crkve)
13293   170       continue
13294             goto 490
13295 !--NORMAL 14-POLE
13296   180       do 190 j=1,napx
13297             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13298      &(xv(2,j)-zsiv(1,i))*tilts(i)
13299             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13300      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13301             crkve=xlv(j)
13302             cikve=zlv(j)
13303            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13304            cikve=crkve*zlv(j)+cikve*xlv(j)
13305            crkve=crkveuk
13306            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13307            cikve=crkve*zlv(j)+cikve*xlv(j)
13308            crkve=crkveuk
13309            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13310            cikve=crkve*zlv(j)+cikve*xlv(j)
13311            crkve=crkveuk
13312            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13313            cikve=crkve*zlv(j)+cikve*xlv(j)
13314            crkve=crkveuk
13315            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13316            cikve=crkve*zlv(j)+cikve*xlv(j)
13317            crkve=crkveuk
13318             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13319      &stracks(i)*cikve)
13320             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13321      &stracks(i)*crkve)
13322   190       continue
13323             goto 490
13324 !--NORMAL 16-POLE
13325   200       do 210 j=1,napx
13326             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13327      &(xv(2,j)-zsiv(1,i))*tilts(i)
13328             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13329      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13330             crkve=xlv(j)
13331             cikve=zlv(j)
13332            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13333            cikve=crkve*zlv(j)+cikve*xlv(j)
13334            crkve=crkveuk
13335            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13336            cikve=crkve*zlv(j)+cikve*xlv(j)
13337            crkve=crkveuk
13338            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13339            cikve=crkve*zlv(j)+cikve*xlv(j)
13340            crkve=crkveuk
13341            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13342            cikve=crkve*zlv(j)+cikve*xlv(j)
13343            crkve=crkveuk
13344            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13345            cikve=crkve*zlv(j)+cikve*xlv(j)
13346            crkve=crkveuk
13347            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13348            cikve=crkve*zlv(j)+cikve*xlv(j)
13349            crkve=crkveuk
13350             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13351      &stracks(i)*cikve)
13352             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13353      &stracks(i)*crkve)
13354   210       continue
13355             goto 490
13356 !--NORMAL 18-POLE
13357   220       do 230 j=1,napx
13358             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13359      &(xv(2,j)-zsiv(1,i))*tilts(i)
13360             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13361      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13362             crkve=xlv(j)
13363             cikve=zlv(j)
13364            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13365            cikve=crkve*zlv(j)+cikve*xlv(j)
13366            crkve=crkveuk
13367            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13368            cikve=crkve*zlv(j)+cikve*xlv(j)
13369            crkve=crkveuk
13370            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13371            cikve=crkve*zlv(j)+cikve*xlv(j)
13372            crkve=crkveuk
13373            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13374            cikve=crkve*zlv(j)+cikve*xlv(j)
13375            crkve=crkveuk
13376            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13377            cikve=crkve*zlv(j)+cikve*xlv(j)
13378            crkve=crkveuk
13379            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13380            cikve=crkve*zlv(j)+cikve*xlv(j)
13381            crkve=crkveuk
13382            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13383            cikve=crkve*zlv(j)+cikve*xlv(j)
13384            crkve=crkveuk
13385             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13386      &stracks(i)*cikve)
13387             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13388      &stracks(i)*crkve)
13389   230       continue
13390             goto 490
13391 !--NORMAL 20-POLE
13392   240       do 250 j=1,napx
13393             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13394      &(xv(2,j)-zsiv(1,i))*tilts(i)
13395             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13396      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13397             crkve=xlv(j)
13398             cikve=zlv(j)
13399            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13400            cikve=crkve*zlv(j)+cikve*xlv(j)
13401            crkve=crkveuk
13402            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13403            cikve=crkve*zlv(j)+cikve*xlv(j)
13404            crkve=crkveuk
13405            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13406            cikve=crkve*zlv(j)+cikve*xlv(j)
13407            crkve=crkveuk
13408            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13409            cikve=crkve*zlv(j)+cikve*xlv(j)
13410            crkve=crkveuk
13411            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13412            cikve=crkve*zlv(j)+cikve*xlv(j)
13413            crkve=crkveuk
13414            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13415            cikve=crkve*zlv(j)+cikve*xlv(j)
13416            crkve=crkveuk
13417            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13418            cikve=crkve*zlv(j)+cikve*xlv(j)
13419            crkve=crkveuk
13420            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13421            cikve=crkve*zlv(j)+cikve*xlv(j)
13422            crkve=crkveuk
13423             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
13424      &stracks(i)*cikve)
13425             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
13426      &stracks(i)*crkve)
13427   250       continue
13428             goto 490
13429   520       continue
13430             do 530 j=1,napx
13431             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13432      &(xv(2,j)-zsiv(1,i))*tilts(i)
13433             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13434      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13435             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
13436      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
13437      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13438             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
13439      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
13440      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13441             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13442   530       continue
13443             goto 490
13444   540       continue
13445             do 550 j=1,napx
13446             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13447      &(xv(2,j)-zsiv(1,i))*tilts(i)
13448             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13449      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13450             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
13451      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
13452      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13453             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
13454      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
13455      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13456             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13457   550       continue
13458             goto 260
13459   560       continue
13460             do 570 j=1,napx
13461             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13462      &(xv(2,j)-zsiv(1,i))*tilts(i)
13463             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13464      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13465             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
13466      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13467             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
13468      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13469             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13470   570       continue
13471             goto 490
13472   580       continue
13473             do 590 j=1,napx
13474             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13475      &(xv(2,j)-zsiv(1,i))*tilts(i)
13476             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13477      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13478             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
13479      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
13480             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
13481      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
13482             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
13483   590       continue
13484             goto 260
13485   600       continue
13486             do 610 j=1,napx
13487             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13488      &(xv(2,j)-zsiv(1,i))*tilts(i)
13489             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13490      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13491             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
13492      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
13493      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13494             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
13495      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
13496      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13497             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13498   610       continue
13499             goto 490
13500   620       continue
13501             do 630 j=1,napx
13502             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13503      &(xv(2,j)-zsiv(1,i))*tilts(i)
13504             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13505      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13506             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
13507      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
13508      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13509             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
13510      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
13511      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13512             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13513   630       continue
13514             goto 260
13515   640       continue
13516             do 650 j=1,napx
13517             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13518      &(xv(2,j)-zsiv(1,i))*tilts(i)
13519             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13520      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13521             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
13522      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13523             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
13524      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13525             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13526   650       continue
13527             goto 490
13528   660       continue
13529             do 670 j=1,napx
13530             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13531      &(xv(2,j)-zsiv(1,i))*tilts(i)
13532             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13533      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13534             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
13535      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
13536             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
13537      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
13538             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
13539   670       continue
13540   260       r0=ek(ix)
13541             nmz=nmu(ix)
13542           if(nmz.ge.2) then
13543             do 280 j=1,napx
13544             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
13545      &(xv(2,j)-zsiv(1,i))*tilts(i)
13546             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
13547      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13548               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
13549               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
13550               crkve=xlvj
13551               cikve=zlvj
13552                 do 270 k=3,nmz
13553                   crkveuk=crkve*xlvj-cikve*zlvj
13554                   cikve=crkve*zlvj+cikve*xlvj
13555                   crkve=crkveuk
13556                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
13557                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
13558   270           continue
13559               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
13560               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
13561   280       continue
13562           else
13563             do 275 j=1,napx
13564               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
13565      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
13566               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
13567      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
13568   275       continue
13569           endif
13570             goto 490
13571 !--SKEW ELEMENTS
13572 !--VERTICAL DIPOLE
13573   290       do 300 j=1,napx
13574             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
13575             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
13576   300       continue
13577             goto 490
13578 !--SKEW QUADRUPOLE
13579   310       do 320 j=1,napx
13580             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13581      &(xv(2,j)-zsiv(1,i))*tilts(i)
13582             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13583      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13584             crkve=xlv(j)
13585             cikve=zlv(j)
13586             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13587      &stracks(i)*crkve)
13588             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13589      &stracks(i)*cikve)
13590   320       continue
13591             goto 490
13592 !--SKEW SEXTUPOLE
13593   330       do 340 j=1,napx
13594             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13595      &(xv(2,j)-zsiv(1,i))*tilts(i)
13596             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13597      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13598             crkve=xlv(j)
13599             cikve=zlv(j)
13600            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13601            cikve=crkve*zlv(j)+cikve*xlv(j)
13602            crkve=crkveuk
13603             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13604      &stracks(i)*crkve)
13605             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13606      &stracks(i)*cikve)
13607   340       continue
13608             goto 490
13609 !--SKEW OCTUPOLE
13610   350       do 360 j=1,napx
13611             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13612      &(xv(2,j)-zsiv(1,i))*tilts(i)
13613             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13614      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13615             crkve=xlv(j)
13616             cikve=zlv(j)
13617            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13618            cikve=crkve*zlv(j)+cikve*xlv(j)
13619            crkve=crkveuk
13620            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13621            cikve=crkve*zlv(j)+cikve*xlv(j)
13622            crkve=crkveuk
13623             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13624      &stracks(i)*crkve)
13625             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13626      &stracks(i)*cikve)
13627   360       continue
13628             goto 490
13629 !--SKEW DECAPOLE
13630   370       do 380 j=1,napx
13631             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13632      &(xv(2,j)-zsiv(1,i))*tilts(i)
13633             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13634      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13635             crkve=xlv(j)
13636             cikve=zlv(j)
13637            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13638            cikve=crkve*zlv(j)+cikve*xlv(j)
13639            crkve=crkveuk
13640            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13641            cikve=crkve*zlv(j)+cikve*xlv(j)
13642            crkve=crkveuk
13643            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13644            cikve=crkve*zlv(j)+cikve*xlv(j)
13645            crkve=crkveuk
13646             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13647      &stracks(i)*crkve)
13648             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13649      &stracks(i)*cikve)
13650   380       continue
13651             goto 490
13652 !--SKEW DODECAPOLE
13653   390       do 400 j=1,napx
13654             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13655      &(xv(2,j)-zsiv(1,i))*tilts(i)
13656             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13657      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13658             crkve=xlv(j)
13659             cikve=zlv(j)
13660            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13661            cikve=crkve*zlv(j)+cikve*xlv(j)
13662            crkve=crkveuk
13663            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13664            cikve=crkve*zlv(j)+cikve*xlv(j)
13665            crkve=crkveuk
13666            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13667            cikve=crkve*zlv(j)+cikve*xlv(j)
13668            crkve=crkveuk
13669            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13670            cikve=crkve*zlv(j)+cikve*xlv(j)
13671            crkve=crkveuk
13672             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13673      &stracks(i)*crkve)
13674             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13675      &stracks(i)*cikve)
13676   400       continue
13677             goto 490
13678 !--SKEW 14-POLE
13679   410       do 420 j=1,napx
13680             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13681      &(xv(2,j)-zsiv(1,i))*tilts(i)
13682             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13683      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13684             crkve=xlv(j)
13685             cikve=zlv(j)
13686            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13687            cikve=crkve*zlv(j)+cikve*xlv(j)
13688            crkve=crkveuk
13689            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13690            cikve=crkve*zlv(j)+cikve*xlv(j)
13691            crkve=crkveuk
13692            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13693            cikve=crkve*zlv(j)+cikve*xlv(j)
13694            crkve=crkveuk
13695            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13696            cikve=crkve*zlv(j)+cikve*xlv(j)
13697            crkve=crkveuk
13698            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13699            cikve=crkve*zlv(j)+cikve*xlv(j)
13700            crkve=crkveuk
13701             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13702      &stracks(i)*crkve)
13703             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13704      &stracks(i)*cikve)
13705   420       continue
13706             goto 490
13707 !--SKEW 16-POLE
13708   430       do 440 j=1,napx
13709             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13710      &(xv(2,j)-zsiv(1,i))*tilts(i)
13711             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13712      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13713             crkve=xlv(j)
13714             cikve=zlv(j)
13715            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13716            cikve=crkve*zlv(j)+cikve*xlv(j)
13717            crkve=crkveuk
13718            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13719            cikve=crkve*zlv(j)+cikve*xlv(j)
13720            crkve=crkveuk
13721            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13722            cikve=crkve*zlv(j)+cikve*xlv(j)
13723            crkve=crkveuk
13724            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13725            cikve=crkve*zlv(j)+cikve*xlv(j)
13726            crkve=crkveuk
13727            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13728            cikve=crkve*zlv(j)+cikve*xlv(j)
13729            crkve=crkveuk
13730            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13731            cikve=crkve*zlv(j)+cikve*xlv(j)
13732            crkve=crkveuk
13733             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13734      &stracks(i)*crkve)
13735             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13736      &stracks(i)*cikve)
13737   440       continue
13738             goto 490
13739 !--SKEW 18-POLE
13740   450       do 460 j=1,napx
13741             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13742      &(xv(2,j)-zsiv(1,i))*tilts(i)
13743             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13744      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13745             crkve=xlv(j)
13746             cikve=zlv(j)
13747            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13748            cikve=crkve*zlv(j)+cikve*xlv(j)
13749            crkve=crkveuk
13750            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13751            cikve=crkve*zlv(j)+cikve*xlv(j)
13752            crkve=crkveuk
13753            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13754            cikve=crkve*zlv(j)+cikve*xlv(j)
13755            crkve=crkveuk
13756            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13757            cikve=crkve*zlv(j)+cikve*xlv(j)
13758            crkve=crkveuk
13759            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13760            cikve=crkve*zlv(j)+cikve*xlv(j)
13761            crkve=crkveuk
13762            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13763            cikve=crkve*zlv(j)+cikve*xlv(j)
13764            crkve=crkveuk
13765            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13766            cikve=crkve*zlv(j)+cikve*xlv(j)
13767            crkve=crkveuk
13768             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13769      &stracks(i)*crkve)
13770             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13771      &stracks(i)*cikve)
13772   460       continue
13773             goto 490
13774 !--SKEW 20-POLE
13775   470       do 480 j=1,napx
13776             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
13777      &(xv(2,j)-zsiv(1,i))*tilts(i)
13778             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
13779      &(xv(2,j)-zsiv(1,i))*tiltc(i)
13780             crkve=xlv(j)
13781             cikve=zlv(j)
13782            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13783            cikve=crkve*zlv(j)+cikve*xlv(j)
13784            crkve=crkveuk
13785            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13786            cikve=crkve*zlv(j)+cikve*xlv(j)
13787            crkve=crkveuk
13788            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13789            cikve=crkve*zlv(j)+cikve*xlv(j)
13790            crkve=crkveuk
13791            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13792            cikve=crkve*zlv(j)+cikve*xlv(j)
13793            crkve=crkveuk
13794            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13795            cikve=crkve*zlv(j)+cikve*xlv(j)
13796            crkve=crkveuk
13797            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13798            cikve=crkve*zlv(j)+cikve*xlv(j)
13799            crkve=crkveuk
13800            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13801            cikve=crkve*zlv(j)+cikve*xlv(j)
13802            crkve=crkveuk
13803            crkveuk=crkve*xlv(j)-cikve*zlv(j)
13804            cikve=crkve*zlv(j)+cikve*xlv(j)
13805            crkve=crkveuk
13806             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
13807      &stracks(i)*crkve)
13808             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
13809      &stracks(i)*cikve)
13810   480       continue
13811           goto 490
13812   680     continue
13813           do 690 j=1,napx
13814               if(ibbc.eq.0) then
13815                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13816                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13817               else
13818                 crkveb(j)=                                              &
13819      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
13820      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13821                 cikveb(j)=                                              &
13822      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
13823      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13824               endif
13825             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
13826             if(rho2b(j).le.pieni)                                       &
13827      &goto 690
13828             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
13829             if(ibbc.eq.0) then
13830               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
13831      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
13832               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
13833      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
13834             else
13835               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
13836      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
13837      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
13838      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13839               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13840               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
13841      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
13842      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
13843      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13844               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13845             endif
13846   690     continue
13847           goto 490
13848   700     continue
13849           if(ibtyp.eq.0) then
13850             do j=1,napx
13851               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
13852               rb(j)=sqrt(r2b(j))
13853               rkb(j)=strack(i)*pisqrt/rb(j)
13854               if(ibbc.eq.0) then
13855                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13856                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13857               else
13858                 crkveb(j)=                                              &
13859      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
13860      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13861                 cikveb(j)=                                              &
13862      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
13863      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13864               endif
13865               xrb(j)=abs(crkveb(j))/rb(j)
13866               zrb(j)=abs(cikveb(j))/rb(j)
13867               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
13868               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
13869      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13870               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13871               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13872               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
13873               if(ibbc.eq.0) then
13874                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13875      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13876                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13877      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13878               else
13879                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13880      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13881      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13882      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13883                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13884                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13885      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13886      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13887      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13888                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13889               endif
13890             enddo
13891           else if(ibtyp.eq.1) then
13892             do j=1,napx
13893               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
13894               rb(j)=sqrt(r2b(j))
13895               rkb(j)=strack(i)*pisqrt/rb(j)
13896               if(ibbc.eq.0) then
13897                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13898                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13899               else
13900                 crkveb(j)=                                              &
13901      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
13902      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13903                 cikveb(j)=                                              &
13904      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
13905      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13906               endif
13907               xrb(j)=abs(crkveb(j))/rb(j)
13908               zrb(j)=abs(cikveb(j))/rb(j)
13909               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
13910      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13911               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13912               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13913             enddo
13914             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
13915             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
13916             do j=1,napx
13917               if(ibbc.eq.0) then
13918                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13919      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13920                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13921      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13922               else
13923                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13924      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13925      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13926      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13927                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13928                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13929      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13930      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13931      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13932                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13933               endif
13934             enddo
13935           endif
13936           goto 490
13937   720     continue
13938           if(ibtyp.eq.0) then
13939             do j=1,napx
13940               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
13941               rb(j)=sqrt(r2b(j))
13942               rkb(j)=strack(i)*pisqrt/rb(j)
13943               if(ibbc.eq.0) then
13944                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13945                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13946               else
13947                 crkveb(j)=                                              &
13948      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
13949      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13950                 cikveb(j)=                                              &
13951      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
13952      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13953               endif
13954               xrb(j)=abs(crkveb(j))/rb(j)
13955               zrb(j)=abs(cikveb(j))/rb(j)
13956               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
13957               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
13958      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
13959               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
13960               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
13961               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
13962               if(ibbc.eq.0) then
13963                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
13964      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
13965                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
13966      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
13967               else
13968                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13969      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13970      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13971      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
13972                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
13973                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
13974      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
13975      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
13976      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
13977                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
13978               endif
13979             enddo
13980           else if(ibtyp.eq.1) then
13981             do j=1,napx
13982               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
13983               rb(j)=sqrt(r2b(j))
13984               rkb(j)=strack(i)*pisqrt/rb(j)
13985               if(ibbc.eq.0) then
13986                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
13987                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
13988               else
13989                 crkveb(j)=                                              &
13990      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
13991      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
13992                 cikveb(j)=                                              &
13993      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
13994      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
13995               endif
13996               xrb(j)=abs(crkveb(j))/rb(j)
13997               zrb(j)=abs(cikveb(j))/rb(j)
13998               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
13999      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
14000               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
14001               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
14002             enddo
14003             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
14004             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
14005             do j=1,napx
14006               if(ibbc.eq.0) then
14007                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
14008      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
14009                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
14010      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
14011               else
14012                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
14013      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
14014      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
14015      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
14016                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
14017                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
14018      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
14019      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
14020      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
14021                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
14022               endif
14023             enddo
14024           endif
14025           goto 490
14026   730     continue
14027 !--Hirata's 6D beam-beam kick
14028             do j=1,napx
14029               track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
14030               track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
14031               track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
14032               track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
14033               track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
14034               track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
14035             enddo
14036             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
14037      &ibbc)
14038             do j=1,napx
14039               xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))-             &
14040      &beamoff(1,imbb(i))
14041               xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))-             &
14042      &beamoff(2,imbb(i))
14043               dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
14044               oidpsv(j)=one/(one+dpsv(j))
14045               yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))-            &
14046      &beamoff(4,imbb(i)))*oidpsv(j)
14047               yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))-            &
14048      &beamoff(5,imbb(i)))*oidpsv(j)
14049               ejfv(j)=dpsv(j)*e0f+e0f
14050               ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
14051               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
14052               if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
14053             enddo
14054           goto 490
14055   740     continue
14056           irrtr=imtr(ix)
14057           do j=1,napx
14058             sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+    &
14059      &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+                  &
14060      &rrtr(irrtr,5,4)*yv(2,j)
14061             pux=xv(1,j)
14062             dpsv3(j)=dpsv(j)*c1e3
14063             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
14064      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
14065             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
14066      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
14067             pux=xv(2,j)
14068             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
14069      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
14070             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
14071      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
14072           enddo
14073  
14074 !----------------------------------------------------------------------
14075  
14076 ! Wire.
14077  
14078           goto 490
14079   745     continue
14080           xory=1
14081           nfree=nturn1(ix)
14082          if(n.gt.nfree) then
14083           nac=n-nfree
14084           pi=4d0*atan(1d0)
14085 !---------ACdipAmp input in Tesla*meter converted to KeV/c
14086 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
14087           acdipamp=ed(ix)*clight*1.0d-3
14088 !---------Qd input in tune units
14089           qd=ek(ix)
14090 !---------ACphase input in radians
14091           acphase=acdipph(ix)
14092           nramp1=nturn2(ix)
14093           nplato=nturn3(ix)
14094           nramp2=nturn4(ix)
14095           do j=1,napx
14096       if (xory.eq.1) then
14097         acdipamp2=acdipamp*tilts(i)
14098         acdipamp1=acdipamp*tiltc(i)
14099       else
14100         acdipamp2=acdipamp*tiltc(i)
14101         acdipamp1=-acdipamp*tilts(i)
14102       endif
14103               if(nramp1.gt.nac) then
14104                 yv(1,j)=yv(1,j)+acdipamp1*                              &
14105      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14106                 yv(2,j)=yv(2,j)+acdipamp2*                              &
14107      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14108               endif
14109               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
14110                 yv(1,j)=yv(1,j)+acdipamp1*                              &
14111      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14112                 yv(2,j)=yv(2,j)+acdipamp2*                              &
14113      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14114               endif
14115               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
14116      &nac)then
14117               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
14118      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14119               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
14120      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14121               endif
14122       enddo
14123       endif
14124           goto 490
14125   746     continue
14126           xory=2
14127           nfree=nturn1(ix)
14128          if(n.gt.nfree) then
14129           nac=n-nfree
14130           pi=4d0*atan(1d0)
14131 !---------ACdipAmp input in Tesla*meter converted to KeV/c
14132 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
14133           acdipamp=ed(ix)*clight*1.0d-3
14134 !---------Qd input in tune units
14135           qd=ek(ix)
14136 !---------ACphase input in radians
14137           acphase=acdipph(ix)
14138           nramp1=nturn2(ix)
14139           nplato=nturn3(ix)
14140           nramp2=nturn4(ix)
14141           do j=1,napx
14142       if (xory.eq.1) then
14143         acdipamp2=acdipamp*tilts(i)
14144         acdipamp1=acdipamp*tiltc(i)
14145       else
14146         acdipamp2=acdipamp*tiltc(i)
14147         acdipamp1=-acdipamp*tilts(i)
14148       endif
14149               if(nramp1.gt.nac) then
14150                 yv(1,j)=yv(1,j)+acdipamp1*                              &
14151      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14152                 yv(2,j)=yv(2,j)+acdipamp2*                              &
14153      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
14154               endif
14155               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
14156                 yv(1,j)=yv(1,j)+acdipamp1*                              &
14157      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14158                 yv(2,j)=yv(2,j)+acdipamp2*                              &
14159      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
14160               endif
14161               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
14162      &nac)then
14163               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
14164      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14165               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
14166      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
14167               endif
14168       enddo
14169       endif
14170           goto 490
14171  
14172 !----------------------------
14173  
14174 ! Wire.
14175  
14176   748     continue
14177 !     magnetic rigidity
14178       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
14179  
14180       ix = ixcav
14181       tx = xrms(ix)
14182       ty = zrms(ix)
14183       dx = xpl(ix)
14184       dy = zpl(ix)
14185       embl = ek(ix)
14186       l = wirel(ix)
14187       cur = ed(ix)
14188  
14189       leff = embl/cos(tx)/cos(ty)
14190       rx = dx *cos(tx)-embl*sin(tx)/2
14191       lin= dx *sin(tx)+embl*cos(tx)/2
14192       ry = dy *cos(ty)-lin *sin(ty)
14193       lin= lin*cos(ty)+dy  *sin(ty)
14194  
14195       do 750 j=1, napx
14196  
14197       xv(1,j) = xv(1,j) * c1m3
14198       xv(2,j) = xv(2,j) * c1m3
14199       yv(1,j) = yv(1,j) * c1m3
14200       yv(2,j) = yv(2,j) * c1m3
14201  
14202 !      print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
14203 !     &yv(2,j)
14204  
14205 !     call drift(-embl/2)
14206  
14207       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14208      &yv(2,j)**2)
14209       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14210      &yv(2,j)**2)
14211  
14212 !     call tilt(tx,ty)
14213  
14214       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
14215      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
14216      &yv(2,j)**2))-tx)
14217       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
14218      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
14219       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
14220      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
14221  
14222       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
14223      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
14224      &yv(2,j)**2))-ty)
14225       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
14226      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
14227       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
14228      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
14229  
14230 !     call drift(lin)
14231  
14232       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
14233      &yv(2,j)**2)
14234       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
14235      &yv(2,j)**2)
14236  
14237 !      call kick(l,cur,lin,rx,ry,chi)
14238  
14239       xi = xv(1,j)-rx
14240       yi = xv(2,j)-ry
14241       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
14242      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
14243      &xi**2+yi**2))
14244 !GRD FOR CONSISTENSY
14245 !      yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)*                  &
14246       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
14247      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
14248      &xi**2+yi**2))
14249  
14250 !     call drift(leff-lin)
14251  
14252       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
14253      &yv(1,j)**2-yv(2,j)**2)
14254       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
14255      &yv(1,j)**2-yv(2,j)**2)
14256  
14257 !     call invtilt(tx,ty)
14258  
14259       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
14260      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
14261      &yv(2,j)**2))+ty)
14262       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
14263      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
14264       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
14265      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
14266  
14267       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
14268      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
14269      &yv(2,j)**2))+tx)
14270       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
14271      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
14272       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
14273      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
14274  
14275 !     call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
14276  
14277       xv(1,j) = xv(1,j) + embl*tan(tx)
14278       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
14279  
14280 !     call drift(-embl/2)
14281  
14282       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14283      &yv(2,j)**2)
14284       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
14285      &yv(2,j)**2)
14286  
14287       xv(1,j) = xv(1,j) * c1e3
14288       xv(2,j) = xv(2,j) * c1e3
14289       yv(1,j) = yv(1,j) * c1e3
14290       yv(2,j) = yv(2,j) * c1e3
14291  
14292 !      print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
14293 !     &yv(2,j)
14294  
14295 !-----------------------------------------------------------------------
14296  
14297   750     continue
14298           goto 490
14299  
14300 !----------------------------
14301  
14302   490       continue
14303           llost=.false.
14304           do j=1,napx
14305              llost=llost.or.                                            &
14306      &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
14307           enddo
14308           if (llost) then
14309              kpz=abs(kp(ix))
14310              if(kpz.eq.2) then
14311                 call lostpar3(i,ix,nthinerr)
14312                 if(nthinerr.ne.0) return
14313              elseif(kpz.eq.3) then
14314                 call lostpar4(i,ix,nthinerr)
14315                 if(nthinerr.ne.0) return
14316              else
14317                 call lostpar2(i,ix,nthinerr)
14318                 if(nthinerr.ne.0) return
14319              endif
14320           endif
14321   500     continue
14322           call lostpart(nthinerr)
14323           if(nthinerr.ne.0) return
14324           if(ntwin.ne.2) call dist1
14325           if(mod(n,nwr(4)).eq.0) call write6(n)
14326   510 continue
14327       return
14328       end
14329       subroutine thck6dua(nthinerr)
14330 !-----------------------------------------------------------------------
14331 !
14332 !  TRACK THICK LENS  6D WITH ACCELERATION
14333 !
14334 !
14335 !  F. SCHMIDT
14336 !-----------------------------------------------------------------------
14337       implicit none
14338       integer i,idz1,idz2,irrtr,ix,j,jb,jmel,jx,k,kpz,n,nmz,nthinerr
14339       double precision cbxb,cbzb,cccc,cikve,cikveb,crkve,crkveb,crkveuk,&
14340      &crxb,crzb,dpsv3,e0fo,e0o,pux,puxve1,puxve2,puzve1,puzve2,r0,r2b,  &
14341      &rb,rho2b,rkb,tkb,xbb,xlvj,xrb,yv1j,yv2j,zbb,zlvj,zrb
14342       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
14343      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
14344      &nrco,ntr,nzfz
14345       parameter(npart = 64,nmac = 1)
14346       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
14347      &nzfz = 300000,mmul = 11)
14348       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
14349      &nema = 15)
14350       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
14351       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
14352       parameter(nmon1 = 600,ncor1 = 600)
14353       parameter(ntr = 20,nbb = 160)
14354       integer ireturn, xory, nac, nfree, nramp1,nplato, nramp2
14355       double precision xv1j,xv2j
14356       double precision acdipamp, qd, acphase,acdipamp2,                 &
14357      &acdipamp1
14358       double precision l,cur,dx,dy,tx,ty,embl,leff,rx,ry,lin,chi,xi,yi
14359       logical llost
14360       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
14361      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
14362      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
14363      &one,pieni,pmae,pmap,three,two,zero
14364       parameter(pieni = 1d-38)
14365       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
14366       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
14367       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
14368       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
14369       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
14370      &1.0d16)
14371       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
14372       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
14373       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
14374       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
14375       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
14376       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
14377       parameter(pmap = 938.271998d0,pmae = .510998902d0)
14378       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
14379       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
14380      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
14381      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
14382      &imc,imtr,iorg,iout,                                               &
14383      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
14384      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
14385      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
14386      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
14387      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
14388      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
14389      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
14390      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
14391      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
14392       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
14393      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
14394      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
14395      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
14396      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
14397      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
14398      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
14399      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
14400      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
14401      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
14402      &acdipph
14403       real hmal
14404       character*16 bez,bezb,bezr,erbez,bezl
14405       character*80 toptit,sixtit,commen
14406       common/erro/ierro,erbez
14407       common/kons/pi,pi2,pisqrt,rad
14408       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
14409       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
14410       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
14411       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
14412       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
14413       common/syos2/rvf(mpa)
14414       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
14415      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
14416       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
14417      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
14418      &iicav,itionc(nele),ition,idp,ncy,ixcav
14419       common/corcom/dpscor,sigcor,icode,idam,its6d
14420       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
14421      &bka(nele,mmul),aka(nele,mmul)
14422       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
14423       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
14424       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
14425      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
14426       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
14427       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
14428      &iout
14429       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
14430       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
14431      &ntco,eui,euii,nlin,bezl(nele)
14432       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
14433      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
14434      &ncororb(nele)
14435       common/apert/apx(nele),apz(nele),ape(3,nele)
14436       common/clos/sigma0(2),iclo,ncorru,ncorrep
14437       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
14438      &ratioe(nele),iratioe(nele),icoe
14439       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
14440       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
14441       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
14442       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
14443       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
14444      &nstart,nstop,iskip,iconv,imad
14445       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
14446       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
14447       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
14448       common/ripp2/nrturn
14449       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
14450       common/pawc/hmal(nplo)
14451       common/tit/sixtit,commen,ithick
14452       common/co6d/clo6(3),clop6(3)
14453       common/dkic/dki(nele,3)
14454       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
14455      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
14456      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
14457      &nbeam,ibbc,ibeco,ibtyp,lhc
14458       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
14459       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
14460       common/wireco/ wirel(nele)
14461       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
14462      &nturn3(nele), nturn4(nele)
14463       integer idz,itra
14464       double precision al,as,chi0,chid,dp1,dps,exz,sigm
14465       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
14466      &dps(mpa),idz(2)
14467       common/anf/chi0,chid,exz(2,6),dp1,itra
14468       integer ichrom,is
14469       double precision alf0,amp,bet0,clo,clop,cro,x,y
14470       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
14471       common/chrom/cro(2),is(2),ichrom
14472       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
14473      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
14474       double precision dpmax,preda,weig1,weig2
14475       character*16 coel
14476       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
14477       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
14478       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
14479      &coel(10)
14480       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
14481      &zsi
14482       real tlim,time0,time1
14483       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
14484      &aai(nblz,mmul),bbi(nblz,mmul)
14485       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
14486       common/damp/damp,ampt
14487       common/ttime/tlim,time0,time1
14488       double precision tasm
14489       common/tasm/tasm(6,6)
14490       integer iv,ixv,nlostp,nms,numxv
14491       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
14492      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
14493      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
14494      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
14495      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
14496      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
14497      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
14498      &zsiv,zsv
14499       logical pstop
14500       common/main1/                                                     &
14501      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
14502      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
14503      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
14504      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
14505      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
14506      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
14507      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
14508      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
14509       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
14510      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
14511      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
14512      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
14513      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
14514      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
14515      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
14516      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
14517      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
14518       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
14519      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
14520      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
14521      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
14522       integer numx
14523       double precision e0f
14524       common/main4/ e0f,numx
14525       integer ktrack,nwri
14526       double precision dpsv1,strack,strackc,stracks
14527       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
14528      &stracks(nblz),dpsv1(npart),nwri
14529       double precision cc,xlim,ylim
14530       parameter(cc = 1.12837916709551d0)
14531       parameter(xlim = 5.33d0)
14532       parameter(ylim = 4.29d0)
14533       dimension crkveb(npart),cikveb(npart),rho2b(npart),tkb(npart),    &
14534      &r2b(npart),rb(npart),rkb(npart),                                  &
14535      &xrb(npart),zrb(npart),xbb(npart),zbb(npart),crxb(npart),          &
14536      &crzb(npart),cbxb(npart),cbzb(npart)
14537       dimension dpsv3(npart)
14538       save
14539 !-----------------------------------------------------------------------
14540       nthinerr=0
14541       idz1=idz(1)
14542       idz2=idz(2)
14543       do 510 n=1,numl
14544           numx=n-1
14545           if(irip.eq.1) call ripple(n)
14546           if(n.le.nde(1)) nwri=nwr(1)
14547           if(n.gt.nde(1).and.n.le.nde(2)) nwri=nwr(2)
14548           if(n.gt.nde(2)) nwri=nwr(3)
14549           if(nwri.eq.0) nwri=numl+numlr+1
14550           if(mod(numx,nwri).eq.0) call writebin(nthinerr)
14551           if(nthinerr.ne.0) return
14552           do 500 i=1,iu
14553             if(ktrack(i).eq.1) then
14554               ix=ic(i)
14555             else
14556               ix=ic(i)-nblo
14557             endif
14558 !----------count 44
14559             goto(20,40,740,500,500,500,500,500,500,500,60,80,100,120,   &
14560      &140,160,180,200,220,240,290,310,330,350,370,390,410,430,          &
14561      &450,470,490,260,520,540,560,580,600,620,640,660,680,700,720       &
14562      &,730,748,500,500,500,500,500,745,746),ktrack(i)
14563             goto 500
14564    20       jmel=mel(ix)
14565             do 30 jb=1,jmel
14566               jx=mtyp(ix,jb)
14567               do 30 j=1,napx
14568                 puxve1=xv(1,j)
14569                 puzve1=yv(1,j)
14570                 puxve2=xv(2,j)
14571                 puzve2=yv(2,j)
14572                 sigmv(j)=sigmv(j)+as(1,1,j,jx)+puxve1*(as(2,1,j,jx)+ as &
14573      &(4,1,j,jx)*puzve1+as(5,1,j,jx)*puxve1)+ puzve1*(as                &
14574      &(3,1,j,jx)+as(6,1,j,jx)*puzve1)                                   &
14575      &+as(1,2,j,jx)+puxve2*(as(2,2,j,jx)+ as                            &
14576      &(4,2,j,jx)*puzve2+as(5,2,j,jx)*puxve2)+ puzve2*(as                &
14577      &(3,2,j,jx)+as(6,2,j,jx)*puzve2)
14578                 xv(1,j)=al(1,1,j,jx)*puxve1+ al(2,1,j,jx)*puzve1+idz1*al&
14579      &(5,1,j,jx)
14580                 xv(2,j)=al(1,2,j,jx)*puxve2+ al(2,2,j,jx)*puzve2+idz2*al&
14581      &(5,2,j,jx)
14582                 yv(1,j)=al(3,1,j,jx)*puxve1+ al(4,1,j,jx)*puzve1+idz1*al&
14583      &(6,1,j,jx)
14584                 yv(2,j)=al(3,2,j,jx)*puxve2+ al(4,2,j,jx)*puzve2+idz2*al&
14585      &(6,2,j,jx)
14586    30       continue
14587             goto 500
14588    40       e0o=e0
14589             e0fo=e0f
14590             call adia(n,e0f)
14591             do 50 j=1,napx
14592               ejf0v(j)=ejfv(j)
14593               if(abs(dppoff).gt.pieni) sigmv(j)=sigmv(j)-sigmoff(i)
14594               if(sigmv(j).lt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
14595               if(kz(ix).eq.12) then
14596                 ejv(j)=ejv(j)+ed(ix)*sin(hsyc(ix)*sigmv(j)+phas+        &
14597      &phasc(ix))
14598               else
14599                 ejv(j)=ejv(j)+hsy(1)*sin(hsy(3)*sigmv(j)+phas)
14600               endif
14601               ejfv(j)=sqrt(ejv(j)*ejv(j)-pma*pma)
14602               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
14603               dpsv(j)=(ejfv(j)-e0f)/e0f
14604               oidpsv(j)=one/(one+dpsv(j))
14605               dpsv1(j)=dpsv(j)*c1e3*oidpsv(j)
14606               if(sigmv(j).gt.zero) sigmv(j)=e0f*e0o/(e0fo*e0)*sigmv(j)
14607               yv(1,j)=ejf0v(j)/ejfv(j)*yv(1,j)
14608    50       yv(2,j)=ejf0v(j)/ejfv(j)*yv(2,j)
14609             if(n.eq.1) write(98,'(1p,6(2x,e25.18))')                    &
14610      &(xv(1,j),yv(1,j),xv(2,j),yv(2,j),sigmv(j),dpsv(j),                &
14611      &j=1,napx)
14612             call synuthck
14613             goto 490
14614 !--HORIZONTAL DIPOLE
14615    60       do 70 j=1,napx
14616             yv(1,j)=yv(1,j)+strackc(i)*oidpsv(j)
14617             yv(2,j)=yv(2,j)+stracks(i)*oidpsv(j)
14618    70       continue
14619             goto 490
14620 !--NORMAL QUADRUPOLE
14621    80       do 90 j=1,napx
14622             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14623      &(xv(2,j)-zsiv(1,i))*tilts(i)
14624             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14625      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14626             crkve=xlv(j)
14627             cikve=zlv(j)
14628             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14629      &stracks(i)*cikve)
14630             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14631      &stracks(i)*crkve)
14632    90       continue
14633             goto 490
14634 !--NORMAL SEXTUPOLE
14635   100       do 110 j=1,napx
14636             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14637      &(xv(2,j)-zsiv(1,i))*tilts(i)
14638             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14639      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14640             crkve=xlv(j)
14641             cikve=zlv(j)
14642            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14643            cikve=crkve*zlv(j)+cikve*xlv(j)
14644            crkve=crkveuk
14645             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14646      &stracks(i)*cikve)
14647             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14648      &stracks(i)*crkve)
14649   110       continue
14650             goto 490
14651 !--NORMAL OCTUPOLE
14652   120       do 130 j=1,napx
14653             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14654      &(xv(2,j)-zsiv(1,i))*tilts(i)
14655             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14656      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14657             crkve=xlv(j)
14658             cikve=zlv(j)
14659            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14660            cikve=crkve*zlv(j)+cikve*xlv(j)
14661            crkve=crkveuk
14662            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14663            cikve=crkve*zlv(j)+cikve*xlv(j)
14664            crkve=crkveuk
14665             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14666      &stracks(i)*cikve)
14667             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14668      &stracks(i)*crkve)
14669   130       continue
14670             goto 490
14671 !--NORMAL DECAPOLE
14672   140       do 150 j=1,napx
14673             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14674      &(xv(2,j)-zsiv(1,i))*tilts(i)
14675             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14676      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14677             crkve=xlv(j)
14678             cikve=zlv(j)
14679            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14680            cikve=crkve*zlv(j)+cikve*xlv(j)
14681            crkve=crkveuk
14682            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14683            cikve=crkve*zlv(j)+cikve*xlv(j)
14684            crkve=crkveuk
14685            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14686            cikve=crkve*zlv(j)+cikve*xlv(j)
14687            crkve=crkveuk
14688             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14689      &stracks(i)*cikve)
14690             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14691      &stracks(i)*crkve)
14692   150       continue
14693             goto 490
14694 !--NORMAL DODECAPOLE
14695   160       do 170 j=1,napx
14696             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14697      &(xv(2,j)-zsiv(1,i))*tilts(i)
14698             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14699      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14700             crkve=xlv(j)
14701             cikve=zlv(j)
14702            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14703            cikve=crkve*zlv(j)+cikve*xlv(j)
14704            crkve=crkveuk
14705            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14706            cikve=crkve*zlv(j)+cikve*xlv(j)
14707            crkve=crkveuk
14708            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14709            cikve=crkve*zlv(j)+cikve*xlv(j)
14710            crkve=crkveuk
14711            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14712            cikve=crkve*zlv(j)+cikve*xlv(j)
14713            crkve=crkveuk
14714             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14715      &stracks(i)*cikve)
14716             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14717      &stracks(i)*crkve)
14718   170       continue
14719             goto 490
14720 !--NORMAL 14-POLE
14721   180       do 190 j=1,napx
14722             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14723      &(xv(2,j)-zsiv(1,i))*tilts(i)
14724             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14725      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14726             crkve=xlv(j)
14727             cikve=zlv(j)
14728            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14729            cikve=crkve*zlv(j)+cikve*xlv(j)
14730            crkve=crkveuk
14731            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14732            cikve=crkve*zlv(j)+cikve*xlv(j)
14733            crkve=crkveuk
14734            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14735            cikve=crkve*zlv(j)+cikve*xlv(j)
14736            crkve=crkveuk
14737            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14738            cikve=crkve*zlv(j)+cikve*xlv(j)
14739            crkve=crkveuk
14740            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14741            cikve=crkve*zlv(j)+cikve*xlv(j)
14742            crkve=crkveuk
14743             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14744      &stracks(i)*cikve)
14745             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14746      &stracks(i)*crkve)
14747   190       continue
14748             goto 490
14749 !--NORMAL 16-POLE
14750   200       do 210 j=1,napx
14751             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14752      &(xv(2,j)-zsiv(1,i))*tilts(i)
14753             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14754      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14755             crkve=xlv(j)
14756             cikve=zlv(j)
14757            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14758            cikve=crkve*zlv(j)+cikve*xlv(j)
14759            crkve=crkveuk
14760            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14761            cikve=crkve*zlv(j)+cikve*xlv(j)
14762            crkve=crkveuk
14763            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14764            cikve=crkve*zlv(j)+cikve*xlv(j)
14765            crkve=crkveuk
14766            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14767            cikve=crkve*zlv(j)+cikve*xlv(j)
14768            crkve=crkveuk
14769            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14770            cikve=crkve*zlv(j)+cikve*xlv(j)
14771            crkve=crkveuk
14772            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14773            cikve=crkve*zlv(j)+cikve*xlv(j)
14774            crkve=crkveuk
14775             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14776      &stracks(i)*cikve)
14777             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14778      &stracks(i)*crkve)
14779   210       continue
14780             goto 490
14781 !--NORMAL 18-POLE
14782   220       do 230 j=1,napx
14783             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14784      &(xv(2,j)-zsiv(1,i))*tilts(i)
14785             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14786      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14787             crkve=xlv(j)
14788             cikve=zlv(j)
14789            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14790            cikve=crkve*zlv(j)+cikve*xlv(j)
14791            crkve=crkveuk
14792            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14793            cikve=crkve*zlv(j)+cikve*xlv(j)
14794            crkve=crkveuk
14795            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14796            cikve=crkve*zlv(j)+cikve*xlv(j)
14797            crkve=crkveuk
14798            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14799            cikve=crkve*zlv(j)+cikve*xlv(j)
14800            crkve=crkveuk
14801            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14802            cikve=crkve*zlv(j)+cikve*xlv(j)
14803            crkve=crkveuk
14804            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14805            cikve=crkve*zlv(j)+cikve*xlv(j)
14806            crkve=crkveuk
14807            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14808            cikve=crkve*zlv(j)+cikve*xlv(j)
14809            crkve=crkveuk
14810             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14811      &stracks(i)*cikve)
14812             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14813      &stracks(i)*crkve)
14814   230       continue
14815             goto 490
14816 !--NORMAL 20-POLE
14817   240       do 250 j=1,napx
14818             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
14819      &(xv(2,j)-zsiv(1,i))*tilts(i)
14820             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
14821      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14822             crkve=xlv(j)
14823             cikve=zlv(j)
14824            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14825            cikve=crkve*zlv(j)+cikve*xlv(j)
14826            crkve=crkveuk
14827            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14828            cikve=crkve*zlv(j)+cikve*xlv(j)
14829            crkve=crkveuk
14830            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14831            cikve=crkve*zlv(j)+cikve*xlv(j)
14832            crkve=crkveuk
14833            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14834            cikve=crkve*zlv(j)+cikve*xlv(j)
14835            crkve=crkveuk
14836            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14837            cikve=crkve*zlv(j)+cikve*xlv(j)
14838            crkve=crkveuk
14839            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14840            cikve=crkve*zlv(j)+cikve*xlv(j)
14841            crkve=crkveuk
14842            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14843            cikve=crkve*zlv(j)+cikve*xlv(j)
14844            crkve=crkveuk
14845            crkveuk=crkve*xlv(j)-cikve*zlv(j)
14846            cikve=crkve*zlv(j)+cikve*xlv(j)
14847            crkve=crkveuk
14848             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*crkve+                &
14849      &stracks(i)*cikve)
14850             yv(2,j)=yv(2,j)+oidpsv(j)*(-strackc(i)*cikve+               &
14851      &stracks(i)*crkve)
14852   250       continue
14853             goto 490
14854   520       continue
14855             do 530 j=1,napx
14856             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14857      &(xv(2,j)-zsiv(1,i))*tilts(i)
14858             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14859      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14860             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
14861      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
14862      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14863             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
14864      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
14865      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14866             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14867   530       continue
14868             goto 490
14869   540       continue
14870             do 550 j=1,napx
14871             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14872      &(xv(2,j)-zsiv(1,i))*tilts(i)
14873             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14874      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14875             yv(1,j)=yv(1,j)-(strack(i)*xlvj*oidpsv(j)                   &
14876      &+dpsv1(j))*dki(ix,1)*tiltc(i)                                     &
14877      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14878             yv(2,j)=yv(2,j)-(strack(i)*xlvj*oidpsv(j)                   &
14879      &+dpsv1(j))*dki(ix,1)*tilts(i)                                     &
14880      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14881             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14882   550       continue
14883             goto 260
14884   560       continue
14885             do 570 j=1,napx
14886             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14887      &(xv(2,j)-zsiv(1,i))*tilts(i)
14888             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14889      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14890             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
14891      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14892             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
14893      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14894             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14895   570       continue
14896             goto 490
14897   580       continue
14898             do 590 j=1,napx
14899             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14900      &(xv(2,j)-zsiv(1,i))*tilts(i)
14901             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14902      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14903             yv(1,j)=yv(1,j)-strackc(i)*dpsv1(j)                         &
14904      &+c1e3*dki(ix,1)*oidpsv(j)*(one-tiltc(i))
14905             yv(2,j)=yv(2,j)-stracks(i)*dpsv1(j)                         &
14906      &+c1e3*dki(ix,1)*oidpsv(j)*tilts(i)
14907             sigmv(j)=sigmv(j)+rvv(j)*dki(ix,1)*xlvj
14908   590       continue
14909             goto 260
14910   600       continue
14911             do 610 j=1,napx
14912             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14913      &(xv(2,j)-zsiv(1,i))*tilts(i)
14914             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14915      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14916             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
14917      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
14918      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14919             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
14920      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
14921      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14922             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14923   610       continue
14924             goto 490
14925   620       continue
14926             do 630 j=1,napx
14927             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14928      &(xv(2,j)-zsiv(1,i))*tilts(i)
14929             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14930      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14931             yv(1,j)=yv(1,j)+(strack(i)*zlvj*oidpsv(j)                   &
14932      &-dpsv1(j))*dki(ix,2)*tilts(i)                                     &
14933      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14934             yv(2,j)=yv(2,j)-(strack(i)*zlvj*oidpsv(j)                   &
14935      &-dpsv1(j))*dki(ix,2)*tiltc(i)                                     &
14936      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14937             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14938   630       continue
14939             goto 260
14940   640       continue
14941             do 650 j=1,napx
14942             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14943      &(xv(2,j)-zsiv(1,i))*tilts(i)
14944             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14945      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14946             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
14947      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14948             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
14949      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14950             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14951   650       continue
14952             goto 490
14953   660       continue
14954             do 670 j=1,napx
14955             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14956      &(xv(2,j)-zsiv(1,i))*tilts(i)
14957             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14958      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14959             yv(1,j)=yv(1,j)-stracks(i)*dpsv1(j)                         &
14960      &+c1e3*dki(ix,2)*oidpsv(j)*tilts(i)
14961             yv(2,j)=yv(2,j)+strackc(i)*dpsv1(j)                         &
14962      &-c1e3*dki(ix,2)*oidpsv(j)*(one-tiltc(i))
14963             sigmv(j)=sigmv(j)-rvv(j)*dki(ix,2)*zlvj
14964   670       continue
14965   260       r0=ek(ix)
14966             nmz=nmu(ix)
14967           if(nmz.ge.2) then
14968             do 280 j=1,napx
14969             xlvj=(xv(1,j)-xsiv(1,i))*tiltc(i)+                          &
14970      &(xv(2,j)-zsiv(1,i))*tilts(i)
14971             zlvj=-(xv(1,j)-xsiv(1,i))*tilts(i)+                         &
14972      &(xv(2,j)-zsiv(1,i))*tiltc(i)
14973               yv1j=bbiv(1,1,i)+bbiv(2,1,i)*xlvj+aaiv(2,1,i)*zlvj
14974               yv2j=aaiv(1,1,i)-bbiv(2,1,i)*zlvj+aaiv(2,1,i)*xlvj
14975               crkve=xlvj
14976               cikve=zlvj
14977                 do 270 k=3,nmz
14978                   crkveuk=crkve*xlvj-cikve*zlvj
14979                   cikve=crkve*zlvj+cikve*xlvj
14980                   crkve=crkveuk
14981                   yv1j=yv1j+bbiv(k,1,i)*crkve+aaiv(k,1,i)*cikve
14982                   yv2j=yv2j-bbiv(k,1,i)*cikve+aaiv(k,1,i)*crkve
14983   270           continue
14984               yv(1,j)=yv(1,j)+(tiltc(i)*yv1j-tilts(i)*yv2j)*oidpsv(j)
14985               yv(2,j)=yv(2,j)+(tiltc(i)*yv2j+tilts(i)*yv1j)*oidpsv(j)
14986   280       continue
14987           else
14988             do 275 j=1,napx
14989               yv(1,j)=yv(1,j)+(tiltc(i)*bbiv(1,1,i)-                    &
14990      &tilts(i)*aaiv(1,1,i))*oidpsv(j)
14991               yv(2,j)=yv(2,j)+(tiltc(i)*aaiv(1,1,i)+                    &
14992      &tilts(i)*bbiv(1,1,i))*oidpsv(j)
14993   275       continue
14994           endif
14995             goto 490
14996 !--SKEW ELEMENTS
14997 !--VERTICAL DIPOLE
14998   290       do 300 j=1,napx
14999             yv(1,j)=yv(1,j)-stracks(i)*oidpsv(j)
15000             yv(2,j)=yv(2,j)+strackc(i)*oidpsv(j)
15001   300       continue
15002             goto 490
15003 !--SKEW QUADRUPOLE
15004   310       do 320 j=1,napx
15005             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15006      &(xv(2,j)-zsiv(1,i))*tilts(i)
15007             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15008      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15009             crkve=xlv(j)
15010             cikve=zlv(j)
15011             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15012      &stracks(i)*crkve)
15013             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15014      &stracks(i)*cikve)
15015   320       continue
15016             goto 490
15017 !--SKEW SEXTUPOLE
15018   330       do 340 j=1,napx
15019             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15020      &(xv(2,j)-zsiv(1,i))*tilts(i)
15021             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15022      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15023             crkve=xlv(j)
15024             cikve=zlv(j)
15025            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15026            cikve=crkve*zlv(j)+cikve*xlv(j)
15027            crkve=crkveuk
15028             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15029      &stracks(i)*crkve)
15030             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15031      &stracks(i)*cikve)
15032   340       continue
15033             goto 490
15034 !--SKEW OCTUPOLE
15035   350       do 360 j=1,napx
15036             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15037      &(xv(2,j)-zsiv(1,i))*tilts(i)
15038             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15039      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15040             crkve=xlv(j)
15041             cikve=zlv(j)
15042            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15043            cikve=crkve*zlv(j)+cikve*xlv(j)
15044            crkve=crkveuk
15045            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15046            cikve=crkve*zlv(j)+cikve*xlv(j)
15047            crkve=crkveuk
15048             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15049      &stracks(i)*crkve)
15050             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15051      &stracks(i)*cikve)
15052   360       continue
15053             goto 490
15054 !--SKEW DECAPOLE
15055   370       do 380 j=1,napx
15056             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15057      &(xv(2,j)-zsiv(1,i))*tilts(i)
15058             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15059      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15060             crkve=xlv(j)
15061             cikve=zlv(j)
15062            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15063            cikve=crkve*zlv(j)+cikve*xlv(j)
15064            crkve=crkveuk
15065            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15066            cikve=crkve*zlv(j)+cikve*xlv(j)
15067            crkve=crkveuk
15068            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15069            cikve=crkve*zlv(j)+cikve*xlv(j)
15070            crkve=crkveuk
15071             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15072      &stracks(i)*crkve)
15073             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15074      &stracks(i)*cikve)
15075   380       continue
15076             goto 490
15077 !--SKEW DODECAPOLE
15078   390       do 400 j=1,napx
15079             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15080      &(xv(2,j)-zsiv(1,i))*tilts(i)
15081             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15082      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15083             crkve=xlv(j)
15084             cikve=zlv(j)
15085            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15086            cikve=crkve*zlv(j)+cikve*xlv(j)
15087            crkve=crkveuk
15088            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15089            cikve=crkve*zlv(j)+cikve*xlv(j)
15090            crkve=crkveuk
15091            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15092            cikve=crkve*zlv(j)+cikve*xlv(j)
15093            crkve=crkveuk
15094            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15095            cikve=crkve*zlv(j)+cikve*xlv(j)
15096            crkve=crkveuk
15097             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15098      &stracks(i)*crkve)
15099             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15100      &stracks(i)*cikve)
15101   400       continue
15102             goto 490
15103 !--SKEW 14-POLE
15104   410       do 420 j=1,napx
15105             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15106      &(xv(2,j)-zsiv(1,i))*tilts(i)
15107             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15108      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15109             crkve=xlv(j)
15110             cikve=zlv(j)
15111            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15112            cikve=crkve*zlv(j)+cikve*xlv(j)
15113            crkve=crkveuk
15114            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15115            cikve=crkve*zlv(j)+cikve*xlv(j)
15116            crkve=crkveuk
15117            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15118            cikve=crkve*zlv(j)+cikve*xlv(j)
15119            crkve=crkveuk
15120            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15121            cikve=crkve*zlv(j)+cikve*xlv(j)
15122            crkve=crkveuk
15123            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15124            cikve=crkve*zlv(j)+cikve*xlv(j)
15125            crkve=crkveuk
15126             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15127      &stracks(i)*crkve)
15128             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15129      &stracks(i)*cikve)
15130   420       continue
15131             goto 490
15132 !--SKEW 16-POLE
15133   430       do 440 j=1,napx
15134             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15135      &(xv(2,j)-zsiv(1,i))*tilts(i)
15136             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15137      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15138             crkve=xlv(j)
15139             cikve=zlv(j)
15140            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15141            cikve=crkve*zlv(j)+cikve*xlv(j)
15142            crkve=crkveuk
15143            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15144            cikve=crkve*zlv(j)+cikve*xlv(j)
15145            crkve=crkveuk
15146            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15147            cikve=crkve*zlv(j)+cikve*xlv(j)
15148            crkve=crkveuk
15149            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15150            cikve=crkve*zlv(j)+cikve*xlv(j)
15151            crkve=crkveuk
15152            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15153            cikve=crkve*zlv(j)+cikve*xlv(j)
15154            crkve=crkveuk
15155            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15156            cikve=crkve*zlv(j)+cikve*xlv(j)
15157            crkve=crkveuk
15158             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15159      &stracks(i)*crkve)
15160             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15161      &stracks(i)*cikve)
15162   440       continue
15163             goto 490
15164 !--SKEW 18-POLE
15165   450       do 460 j=1,napx
15166             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15167      &(xv(2,j)-zsiv(1,i))*tilts(i)
15168             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15169      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15170             crkve=xlv(j)
15171             cikve=zlv(j)
15172            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15173            cikve=crkve*zlv(j)+cikve*xlv(j)
15174            crkve=crkveuk
15175            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15176            cikve=crkve*zlv(j)+cikve*xlv(j)
15177            crkve=crkveuk
15178            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15179            cikve=crkve*zlv(j)+cikve*xlv(j)
15180            crkve=crkveuk
15181            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15182            cikve=crkve*zlv(j)+cikve*xlv(j)
15183            crkve=crkveuk
15184            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15185            cikve=crkve*zlv(j)+cikve*xlv(j)
15186            crkve=crkveuk
15187            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15188            cikve=crkve*zlv(j)+cikve*xlv(j)
15189            crkve=crkveuk
15190            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15191            cikve=crkve*zlv(j)+cikve*xlv(j)
15192            crkve=crkveuk
15193             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15194      &stracks(i)*crkve)
15195             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15196      &stracks(i)*cikve)
15197   460       continue
15198             goto 490
15199 !--SKEW 20-POLE
15200   470       do 480 j=1,napx
15201             xlv(j)=(xv(1,j)-xsiv(1,i))*tiltc(i)+                        &
15202      &(xv(2,j)-zsiv(1,i))*tilts(i)
15203             zlv(j)=-(xv(1,j)-xsiv(1,i))*tilts(i)+                       &
15204      &(xv(2,j)-zsiv(1,i))*tiltc(i)
15205             crkve=xlv(j)
15206             cikve=zlv(j)
15207            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15208            cikve=crkve*zlv(j)+cikve*xlv(j)
15209            crkve=crkveuk
15210            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15211            cikve=crkve*zlv(j)+cikve*xlv(j)
15212            crkve=crkveuk
15213            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15214            cikve=crkve*zlv(j)+cikve*xlv(j)
15215            crkve=crkveuk
15216            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15217            cikve=crkve*zlv(j)+cikve*xlv(j)
15218            crkve=crkveuk
15219            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15220            cikve=crkve*zlv(j)+cikve*xlv(j)
15221            crkve=crkveuk
15222            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15223            cikve=crkve*zlv(j)+cikve*xlv(j)
15224            crkve=crkveuk
15225            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15226            cikve=crkve*zlv(j)+cikve*xlv(j)
15227            crkve=crkveuk
15228            crkveuk=crkve*xlv(j)-cikve*zlv(j)
15229            cikve=crkve*zlv(j)+cikve*xlv(j)
15230            crkve=crkveuk
15231             yv(1,j)=yv(1,j)+oidpsv(j)*(strackc(i)*cikve-                &
15232      &stracks(i)*crkve)
15233             yv(2,j)=yv(2,j)+oidpsv(j)*(strackc(i)*crkve+                &
15234      &stracks(i)*cikve)
15235   480       continue
15236           goto 490
15237   680     continue
15238           do 690 j=1,napx
15239               if(ibbc.eq.0) then
15240                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15241                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15242               else
15243                 crkveb(j)=                                              &
15244      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
15245      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15246                 cikveb(j)=                                              &
15247      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
15248      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15249               endif
15250             rho2b(j)=crkveb(j)*crkveb(j)+cikveb(j)*cikveb(j)
15251             if(rho2b(j).le.pieni)                                       &
15252      &goto 690
15253             tkb(j)=rho2b(j)/(two*sigman2(1,imbb(i)))
15254             if(ibbc.eq.0) then
15255               yv(1,j)=yv(1,j)+oidpsv(j)*(strack(i)*crkveb(j)/rho2b(j)*  &
15256      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))
15257               yv(2,j)=yv(2,j)+oidpsv(j)*(strack(i)*cikveb(j)/rho2b(j)*  &
15258      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))
15259             else
15260               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
15261      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),11)-          &
15262      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
15263      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15264               yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15265               cccc=(strack(i)*crkveb(j)/rho2b(j)*                       &
15266      &(one-exp(-tkb(j)))-beamoff(4,imbb(i)))*bbcu(imbb(i),12)+          &
15267      &(strack(i)*cikveb(j)/rho2b(j)*                                    &
15268      &(one-exp(-tkb(j)))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15269               yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15270             endif
15271   690     continue
15272           goto 490
15273   700     continue
15274           if(ibtyp.eq.0) then
15275             do j=1,napx
15276               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
15277               rb(j)=sqrt(r2b(j))
15278               rkb(j)=strack(i)*pisqrt/rb(j)
15279               if(ibbc.eq.0) then
15280                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15281                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15282               else
15283                 crkveb(j)=                                              &
15284      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
15285      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15286                 cikveb(j)=                                              &
15287      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
15288      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15289               endif
15290               xrb(j)=abs(crkveb(j))/rb(j)
15291               zrb(j)=abs(cikveb(j))/rb(j)
15292               call errf(xrb(j),zrb(j),crxb(j),crzb(j))
15293               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
15294      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15295               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15296               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15297               call errf(xbb(j),zbb(j),cbxb(j),cbzb(j))
15298               if(ibbc.eq.0) then
15299                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15300      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15301                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15302      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15303               else
15304                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15305      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15306      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15307      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15308                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15309                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15310      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15311      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15312      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15313                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15314               endif
15315             enddo
15316           else if(ibtyp.eq.1) then
15317             do j=1,napx
15318               r2b(j)=two*(sigman2(1,imbb(i))-sigman2(2,imbb(i)))
15319               rb(j)=sqrt(r2b(j))
15320               rkb(j)=strack(i)*pisqrt/rb(j)
15321               if(ibbc.eq.0) then
15322                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15323                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15324               else
15325                 crkveb(j)=                                              &
15326      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
15327      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15328                 cikveb(j)=                                              &
15329      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
15330      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15331               endif
15332               xrb(j)=abs(crkveb(j))/rb(j)
15333               zrb(j)=abs(cikveb(j))/rb(j)
15334               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
15335      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15336               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15337               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15338             enddo
15339             call wzsubv(napx,xrb(1),zrb(1),crxb(1),crzb(1))
15340             call wzsubv(napx,xbb(1),zbb(1),cbxb(1),cbzb(1))
15341             do j=1,napx
15342               if(ibbc.eq.0) then
15343                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15344      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15345                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15346      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15347               else
15348                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15349      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15350      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15351      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15352                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15353                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15354      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15355      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15356      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15357                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15358               endif
15359             enddo
15360           endif
15361           goto 490
15362   720     continue
15363           if(ibtyp.eq.0) then
15364             do j=1,napx
15365               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
15366               rb(j)=sqrt(r2b(j))
15367               rkb(j)=strack(i)*pisqrt/rb(j)
15368               if(ibbc.eq.0) then
15369                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15370                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15371               else
15372                 crkveb(j)=                                              &
15373      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
15374      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15375                 cikveb(j)=                                              &
15376      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
15377      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15378               endif
15379               xrb(j)=abs(crkveb(j))/rb(j)
15380               zrb(j)=abs(cikveb(j))/rb(j)
15381               call errf(zrb(j),xrb(j),crzb(j),crxb(j))
15382               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
15383      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15384               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15385               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15386               call errf(zbb(j),xbb(j),cbzb(j),cbxb(j))
15387               if(ibbc.eq.0) then
15388                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15389      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15390                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15391      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15392               else
15393                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15394      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15395      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15396      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15397                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15398                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15399      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15400      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15401      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15402                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15403               endif
15404             enddo
15405           else if(ibtyp.eq.1) then
15406             do j=1,napx
15407               r2b(j)=two*(sigman2(2,imbb(i))-sigman2(1,imbb(i)))
15408               rb(j)=sqrt(r2b(j))
15409               rkb(j)=strack(i)*pisqrt/rb(j)
15410               if(ibbc.eq.0) then
15411                 crkveb(j)=xv(1,j)-clobeam(1,imbb(i))+ed(ix)
15412                 cikveb(j)=xv(2,j)-clobeam(2,imbb(i))+ek(ix)
15413               else
15414                 crkveb(j)=                                              &
15415      &(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),11)+             &
15416      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),12)
15417                 cikveb(j)=                                              &
15418      &-(xv(1,j)-clobeam(1,imbb(i))+ed(ix))*bbcu(imbb(i),12)+            &
15419      &(xv(2,j)-clobeam(2,imbb(i))+ek(ix))*bbcu(imbb(i),11)
15420               endif
15421               xrb(j)=abs(crkveb(j))/rb(j)
15422               zrb(j)=abs(cikveb(j))/rb(j)
15423               tkb(j)=(crkveb(j)*crkveb(j)/sigman2(1,imbb(i))+           &
15424      &cikveb(j)*cikveb(j)/sigman2(2,imbb(i)))*half
15425               xbb(j)=sigmanq(2,imbb(i))*xrb(j)
15426               zbb(j)=sigmanq(1,imbb(i))*zrb(j)
15427             enddo
15428             call wzsubv(napx,zrb(1),xrb(1),crzb(1),crxb(1))
15429             call wzsubv(napx,zbb(1),xbb(1),cbzb(1),cbxb(1))
15430             do j=1,napx
15431               if(ibbc.eq.0) then
15432                 yv(1,j)=yv(1,j)+oidpsv(j)*(rkb(j)*(crzb(j)-exp(-tkb(j))*&
15433      &cbzb(j))*sign(one,crkveb(j))-beamoff(4,imbb(i)))
15434                 yv(2,j)=yv(2,j)+oidpsv(j)*(rkb(j)*(crxb(j)-exp(-tkb(j))*&
15435      &cbxb(j))*sign(one,cikveb(j))-beamoff(5,imbb(i)))
15436               else
15437                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15438      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15439      &bbcu(imbb(i),11)-(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15440      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),12)
15441                 yv(1,j)=yv(1,j)+oidpsv(j)*cccc
15442                 cccc=(rkb(j)*(crzb(j)-exp(-tkb(j))*cbzb(j))*            &
15443      &sign(one,crkveb(j))-beamoff(4,imbb(i)))*                          &
15444      &bbcu(imbb(i),12)+(rkb(j)*(crxb(j)-exp(-tkb(j))*cbxb(j))*          &
15445      &sign(one,cikveb(j))-beamoff(5,imbb(i)))*bbcu(imbb(i),11)
15446                 yv(2,j)=yv(2,j)+oidpsv(j)*cccc
15447               endif
15448             enddo
15449           endif
15450           goto 490
15451   730     continue
15452 !--Hirata's 6D beam-beam kick
15453             do j=1,napx
15454               track6d(1,j)=(xv(1,j)+ed(ix)-clobeam(1,imbb(i)))*c1m3
15455               track6d(2,j)=(yv(1,j)/oidpsv(j)-clobeam(4,imbb(i)))*c1m3
15456               track6d(3,j)=(xv(2,j)+ek(ix)-clobeam(2,imbb(i)))*c1m3
15457               track6d(4,j)=(yv(2,j)/oidpsv(j)-clobeam(5,imbb(i)))*c1m3
15458               track6d(5,j)=(sigmv(j)-clobeam(3,imbb(i)))*c1m3
15459               track6d(6,j)=dpsv(j)-clobeam(6,imbb(i))
15460             enddo
15461             call beamint(napx,track6d,parbe,sigz,bbcu,imbb(i),ix,ibtyp, &
15462      &ibbc)
15463             do j=1,napx
15464               xv(1,j)=track6d(1,j)*c1e3+clobeam(1,imbb(i))-             &
15465      &beamoff(1,imbb(i))
15466               xv(2,j)=track6d(3,j)*c1e3+clobeam(2,imbb(i))-             &
15467      &beamoff(2,imbb(i))
15468               dpsv(j)=track6d(6,j)+clobeam(6,imbb(i))-beamoff(6,imbb(i))
15469               oidpsv(j)=one/(one+dpsv(j))
15470               yv(1,j)=(track6d(2,j)*c1e3+clobeam(4,imbb(i))-            &
15471      &beamoff(4,imbb(i)))*oidpsv(j)
15472               yv(2,j)=(track6d(4,j)*c1e3+clobeam(5,imbb(i))-            &
15473      &beamoff(5,imbb(i)))*oidpsv(j)
15474               ejfv(j)=dpsv(j)*e0f+e0f
15475               ejv(j)=sqrt(ejfv(j)*ejfv(j)+pma*pma)
15476               rvv(j)=(ejv(j)*e0f)/(e0*ejfv(j))
15477               if(ithick.eq.1) call envarsv(dpsv,oidpsv,rvv,ekv)
15478             enddo
15479           goto 490
15480   740     continue
15481           irrtr=imtr(ix)
15482           do j=1,napx
15483             sigmv(j)=sigmv(j)+cotr(irrtr,5)+rrtr(irrtr,5,1)*xv(1,j)+    &
15484      &rrtr(irrtr,5,2)*yv(1,j)+rrtr(irrtr,5,3)*xv(2,j)+                  &
15485      &rrtr(irrtr,5,4)*yv(2,j)
15486             pux=xv(1,j)
15487             dpsv3(j)=dpsv(j)*c1e3
15488             xv(1,j)=cotr(irrtr,1)+rrtr(irrtr,1,1)*pux+                  &
15489      &rrtr(irrtr,1,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,1,6)
15490             yv(1,j)=cotr(irrtr,2)+rrtr(irrtr,2,1)*pux+                  &
15491      &rrtr(irrtr,2,2)*yv(1,j)+idz(1)*dpsv3(j)*rrtr(irrtr,2,6)
15492             pux=xv(2,j)
15493             xv(2,j)=cotr(irrtr,3)+rrtr(irrtr,3,3)*pux+                  &
15494      &rrtr(irrtr,3,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,3,6)
15495             yv(2,j)=cotr(irrtr,4)+rrtr(irrtr,4,3)*pux+                  &
15496      &rrtr(irrtr,4,4)*yv(2,j)+idz(2)*dpsv3(j)*rrtr(irrtr,4,6)
15497           enddo
15498  
15499 !----------------------------------------------------------------------
15500  
15501 ! Wire.
15502  
15503           goto 490
15504   745     continue
15505           xory=1
15506           nfree=nturn1(ix)
15507          if(n.gt.nfree) then
15508           nac=n-nfree
15509           pi=4d0*atan(1d0)
15510 !---------ACdipAmp input in Tesla*meter converted to KeV/c
15511 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
15512           acdipamp=ed(ix)*clight*1.0d-3
15513 !---------Qd input in tune units
15514           qd=ek(ix)
15515 !---------ACphase input in radians
15516           acphase=acdipph(ix)
15517           nramp1=nturn2(ix)
15518           nplato=nturn3(ix)
15519           nramp2=nturn4(ix)
15520           do j=1,napx
15521       if (xory.eq.1) then
15522         acdipamp2=acdipamp*tilts(i)
15523         acdipamp1=acdipamp*tiltc(i)
15524       else
15525         acdipamp2=acdipamp*tiltc(i)
15526         acdipamp1=-acdipamp*tilts(i)
15527       endif
15528               if(nramp1.gt.nac) then
15529                 yv(1,j)=yv(1,j)+acdipamp1*                              &
15530      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15531                 yv(2,j)=yv(2,j)+acdipamp2*                              &
15532      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15533               endif
15534               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
15535                 yv(1,j)=yv(1,j)+acdipamp1*                              &
15536      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15537                 yv(2,j)=yv(2,j)+acdipamp2*                              &
15538      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15539               endif
15540               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
15541      &nac)then
15542               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
15543      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15544               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
15545      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15546               endif
15547       enddo
15548       endif
15549           goto 490
15550   746     continue
15551           xory=2
15552           nfree=nturn1(ix)
15553          if(n.gt.nfree) then
15554           nac=n-nfree
15555           pi=4d0*atan(1d0)
15556 !---------ACdipAmp input in Tesla*meter converted to KeV/c
15557 !---------ejfv(j) should be in MeV/c --> ACdipAmp/ejfv(j) is in mrad
15558           acdipamp=ed(ix)*clight*1.0d-3
15559 !---------Qd input in tune units
15560           qd=ek(ix)
15561 !---------ACphase input in radians
15562           acphase=acdipph(ix)
15563           nramp1=nturn2(ix)
15564           nplato=nturn3(ix)
15565           nramp2=nturn4(ix)
15566           do j=1,napx
15567       if (xory.eq.1) then
15568         acdipamp2=acdipamp*tilts(i)
15569         acdipamp1=acdipamp*tiltc(i)
15570       else
15571         acdipamp2=acdipamp*tiltc(i)
15572         acdipamp1=-acdipamp*tilts(i)
15573       endif
15574               if(nramp1.gt.nac) then
15575                 yv(1,j)=yv(1,j)+acdipamp1*                              &
15576      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15577                 yv(2,j)=yv(2,j)+acdipamp2*                              &
15578      &sin(2d0*pi*qd*nac+acphase)*nac/dble(nramp1)/ejfv(j)
15579               endif
15580               if(nac.ge.nramp1.and.(nramp1+nplato).gt.nac) then
15581                 yv(1,j)=yv(1,j)+acdipamp1*                              &
15582      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15583                 yv(2,j)=yv(2,j)+acdipamp2*                              &
15584      &sin(2d0*pi*qd*nac+acphase)/ejfv(j)
15585               endif
15586               if(nac.ge.(nramp1+nplato).and.(nramp2+nramp1+nplato).gt.  &
15587      &nac)then
15588               yv(1,j)=yv(1,j)+acdipamp1*sin(2d0*pi*qd*nac+acphase)*     &
15589      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15590               yv(2,j)=yv(2,j)+acdipamp2*sin(2d0*pi*qd*nac+acphase)*     &
15591      &(-(nac-nramp1-nramp2-nplato)*1d0/dble(nramp2))/ejfv(j)
15592               endif
15593       enddo
15594       endif
15595           goto 490
15596  
15597 !----------------------------
15598  
15599 ! Wire.
15600  
15601   748     continue
15602 !     magnetic rigidity
15603       chi = sqrt(e0*e0-pmap*pmap)*c1e6/clight
15604  
15605       ix = ixcav
15606       tx = xrms(ix)
15607       ty = zrms(ix)
15608       dx = xpl(ix)
15609       dy = zpl(ix)
15610       embl = ek(ix)
15611       l = wirel(ix)
15612       cur = ed(ix)
15613  
15614       leff = embl/cos(tx)/cos(ty)
15615       rx = dx *cos(tx)-embl*sin(tx)/2
15616       lin= dx *sin(tx)+embl*cos(tx)/2
15617       ry = dy *cos(ty)-lin *sin(ty)
15618       lin= lin*cos(ty)+dy  *sin(ty)
15619  
15620       do 750 j=1, napx
15621  
15622       xv(1,j) = xv(1,j) * c1m3
15623       xv(2,j) = xv(2,j) * c1m3
15624       yv(1,j) = yv(1,j) * c1m3
15625       yv(2,j) = yv(2,j) * c1m3
15626  
15627 !      print *, 'Start: ',j,xv(1,j),xv(2,j),yv(1,j),
15628 !     &yv(2,j)
15629  
15630 !     call drift(-embl/2)
15631  
15632       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15633      &yv(2,j)**2)
15634       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15635      &yv(2,j)**2)
15636  
15637 !     call tilt(tx,ty)
15638  
15639       xv(2,j) = xv(2,j)-xv(1,j)*sin(tx)*yv(2,j)/sqrt((1+dpsv(j))**2-    &
15640      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
15641      &yv(2,j)**2))-tx)
15642       xv(1,j) = xv(1,j)*(cos(tx)-sin(tx)*tan(atan(yv(1,j)/              &
15643      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx))
15644       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
15645      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-tx)
15646  
15647       xv(1,j) = xv(1,j)-xv(2,j)*sin(ty)*yv(1,j)/sqrt((1+dpsv(j))**2-    &
15648      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
15649      &yv(2,j)**2))-ty)
15650       xv(2,j) = xv(2,j)*(cos(ty)-sin(ty)*tan(atan(yv(2,j)/              &
15651      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty))
15652       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
15653      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))-ty)
15654  
15655 !     call drift(lin)
15656  
15657       xv(1,j) = xv(1,j) + lin*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
15658      &yv(2,j)**2)
15659       xv(2,j) = xv(2,j) + lin*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-   &
15660      &yv(2,j)**2)
15661  
15662 !      call kick(l,cur,lin,rx,ry,chi)
15663  
15664       xi = xv(1,j)-rx
15665       yi = xv(2,j)-ry
15666       yv(1,j) = yv(1,j)-1.0d-7*cur/chi*xi/(xi**2+yi**2)*                &
15667      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
15668      &xi**2+yi**2))
15669 !GRD FOR CONSISTENSY
15670 !      yv(2,j) = yv(2,j)-1e-7*cur/chi*yi/(xi**2+yi**2)*                  &
15671       yv(2,j) = yv(2,j)-1.0d-7*cur/chi*yi/(xi**2+yi**2)*                &
15672      &(sqrt((lin+l)**2+xi**2+yi**2)-sqrt((lin-l)**2+                    &
15673      &xi**2+yi**2))
15674  
15675 !     call drift(leff-lin)
15676  
15677       xv(1,j) = xv(1,j) + (leff-lin)*yv(1,j)/sqrt((1+dpsv(j))**2-       &
15678      &yv(1,j)**2-yv(2,j)**2)
15679       xv(2,j) = xv(2,j) + (leff-lin)*yv(2,j)/sqrt((1+dpsv(j))**2-       &
15680      &yv(1,j)**2-yv(2,j)**2)
15681  
15682 !     call invtilt(tx,ty)
15683  
15684       xv(1,j) = xv(1,j)-xv(2,j)*sin(-ty)*yv(1,j)/sqrt((1+dpsv(j))**2-   &
15685      &yv(1,j)**2)/cos(atan(yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
15686      &yv(2,j)**2))+ty)
15687       xv(2,j) = xv(2,j)*(cos(-ty)-sin(-ty)*tan(atan(yv(2,j)/            &
15688      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty))
15689       yv(2,j) = sqrt((1+dpsv(j))**2-yv(1,j)**2)*sin(atan(yv(2,j)/       &
15690      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+ty)
15691  
15692       xv(2,j) = xv(2,j)-xv(1,j)*sin(-tx)*yv(2,j)/sqrt((1+dpsv(j))**2-   &
15693      &yv(2,j)**2)/cos(atan(yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-      &
15694      &yv(2,j)**2))+tx)
15695       xv(1,j) = xv(1,j)*(cos(-tx)-sin(-tx)*tan(atan(yv(1,j)/            &
15696      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx))
15697       yv(1,j) = sqrt((1+dpsv(j))**2-yv(2,j)**2)*sin(atan(yv(1,j)/       &
15698      &sqrt((1+dpsv(j))**2-yv(1,j)**2-yv(2,j)**2))+tx)
15699  
15700 !     call shift(-embl*tan(tx),-embl*tan(ty)/cos(tx))
15701  
15702       xv(1,j) = xv(1,j) + embl*tan(tx)
15703       xv(2,j) = xv(2,j) + embl*tan(ty)/cos(tx)
15704  
15705 !     call drift(-embl/2)
15706  
15707       xv(1,j) = xv(1,j) - embl/2*yv(1,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15708      &yv(2,j)**2)
15709       xv(2,j) = xv(2,j) - embl/2*yv(2,j)/sqrt((1+dpsv(j))**2-yv(1,j)**2-&
15710      &yv(2,j)**2)
15711  
15712       xv(1,j) = xv(1,j) * c1e3
15713       xv(2,j) = xv(2,j) * c1e3
15714       yv(1,j) = yv(1,j) * c1e3
15715       yv(2,j) = yv(2,j) * c1e3
15716  
15717 !      print *, 'End: ',j,xv(1,j),xv(2,j),yv(1,j),
15718 !     &yv(2,j)
15719  
15720 !-----------------------------------------------------------------------
15721  
15722   750     continue
15723           goto 490
15724  
15725 !----------------------------
15726  
15727   490       continue
15728           llost=.false.
15729           do j=1,napx
15730              llost=llost.or.                                            &
15731      &abs(xv(1,j)).gt.aper(1).or.abs(xv(2,j)).gt.aper(2)
15732           enddo
15733           if (llost) then
15734              kpz=abs(kp(ix))
15735              if(kpz.eq.2) then
15736                 call lostpar3(i,ix,nthinerr)
15737                 if(nthinerr.ne.0) return
15738              elseif(kpz.eq.3) then
15739                 call lostpar4(i,ix,nthinerr)
15740                 if(nthinerr.ne.0) return
15741              else
15742                 call lostpar2(i,ix,nthinerr)
15743                 if(nthinerr.ne.0) return
15744              endif
15745           endif
15746   500     continue
15747           call lostpart(nthinerr)
15748           if(nthinerr.ne.0) return
15749           if(ntwin.ne.2) call dist1
15750           if(mod(n,nwr(4)).eq.0) call write6(n)
15751   510 continue
15752       return
15753       end
15754       subroutine synuthck
15755 !-----------------------------------------------------------------------
15756 !
15757 !  TRACK THICK LENS PART
15758 !
15759 !
15760 !  F. SCHMIDT
15761 !-----------------------------------------------------------------------
15762 !  3 February 1999
15763 !-----------------------------------------------------------------------
15764       implicit none
15765       integer ih1,ih2,j,kz1,l
15766       double precision fokm
15767       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
15768      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
15769      &nrco,ntr,nzfz
15770       parameter(npart = 64,nmac = 1)
15771       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
15772      &nzfz = 300000,mmul = 11)
15773       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
15774      &nema = 15)
15775       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
15776       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
15777       parameter(nmon1 = 600,ncor1 = 600)
15778       parameter(ntr = 20,nbb = 160)
15779       double precision c180e0,c1e1,c1e12,c1e13,c1e15,c1e16,c1e2,c1e3,   &
15780      &c1e4,c1e6,c1m1,c1m7,c1m10,c1m12,c1m13,c1m15,c1m18,c1m2,c1m21,     &
15781      &c1m24,c1m3,c1m36,c1m38,c1m6,c1m9,c2e3,c4e3,crade,clight,four,half,&
15782      &one,pieni,pmae,pmap,three,two,zero
15783       parameter(pieni = 1d-38)
15784       parameter(zero = 0.0d0,half = 0.5d0,one = 1.0d0)
15785       parameter(two = 2.0d0,three = 3.0d0,four = 4.0d0)
15786       parameter(c1e1 = 1.0d1,c1e2 = 1.0d2,c1m2 = 1.0d-2)
15787       parameter(c1e3 = 1.0d3,c2e3 = 2.0d3,c4e3 = 4.0d3,c1e4 = 1.0d4)
15788       parameter(c1e12 = 1.0d12,c1e13 = 1.0d13,c1e15 = 1.0d15,c1e16 =    &
15789      &1.0d16)
15790       parameter(c180e0 = 180.0d0,c1e6 = 1.0d6)
15791       parameter(c1m1 = 1.0d-1,c1m3 = 1.0d-3,c1m6 = 1.0d-6,c1m7 = 1.0d-7)
15792       parameter(c1m9 = 1.0d-9,c1m10 = 1.0d-10,c1m12 = 1.0d-12)
15793       parameter(c1m13 = 1.0d-13,c1m15 = 1.0d-15)
15794       parameter(c1m18 = 1.0d-18,c1m21 = 1.0d-21,c1m24 = 1.0d-24)
15795       parameter(c1m36 = 1.0d-36,c1m38 = 1.0d-38)
15796       parameter(pmap = 938.271998d0,pmae = .510998902d0)
15797       parameter(crade = 2.817940285d-15, clight = 2.99792458d8)
15798       integer iav,ibb6d,ibbc,ibeco,ibidu,ibtyp,ic,icext,icextal,iclo,   &
15799      &iclo6,iclo6r,icode,icoe,icomb,icomb0,iconv,icow,icr,idam,idfor,   &
15800      &idis,idp,ierro,iffw,ifh,iicav,il,ilin,imad,imbb,                  &
15801      &imc,imtr,iorg,iout,                                               &
15802      &ipos,ipr,iprint,ipt,iq,iqmod,iqmod6,iratioe,irco,ird,ire,ires,    &
15803      &irew,irip,irm,irmod2,ise,ise1,ise2,ise3,isea,iskew,iskip,istw,    &
15804      &isub,itco,itcro,itf,ithick,ition,itionc,itqv,its6d,iu,iver,ivox,  &
15805      &ivoz,iwg,ixcav,izu0,kanf,kp,kpa,kwtype,kz,lhc,m21,m22,m23,mblo,   &
15806      &mbloz,mcut,mel,mesa,mmac,mout2,mp,mper,mstr,msym,mtyp,mzu,napx,   &
15807      &napxo,nbeam,nch,ncororb,ncorrep,ncorru,ncy,ndafi,nde,nhcorr,      &
15808      &nhmoni,niu,nlin,nmu,npp,nprint,nqc,nre,nrel,nrr,nrturn,nskew,     &
15809      &nstart,nstop,nt,nta,ntco,nte,ntwin,nu,numl,numlr,nur,nvcorr,      &
15810      &nvmoni,nwr, nturn1, nturn2, nturn3, nturn4
15811       double precision a,ak0,aka,alfx,alfz,amp0,aper,apx,apz,ape,bbcu,  &
15812      &bclorb,beamoff,benkc,benki,betac,betam,betx,betz,bk0,bka,bl1,bl2, &
15813      &clo6,clobeam,clop6,cma1,cma2,cotr,crad,de0,dech,ded,dfft,         &
15814      &di0,dip0,dki,dkq,dma,dmap,dphix,dphiz,dppoff,dpscor,dqq,dres,dsi, &
15815      &dsm0,dtr,e0,ed,ej,ejf,ek,el,elbe,emitx,emity,emitz,extalign,      &
15816      &exterr,eui,euii,gammar,hsy,hsyc,pac,pam,parbe,parbe14,partnum,    &
15817      &phas,phas0,phasc,pi,pi2,pisqrt,pma,ptnfac,qs,qw0,qwsk,qx0,qxt,qz0,&
15818      &qzt,r00,rad,ramp,rat,ratio,ratioe,rfre,rrtr,rtc,rts,rvf,rzph,     &
15819      &sigcor,sige,sigma0,sigman,sigman2,sigmanq,sigmoff,sigz,sm,ta,tam1,&
15820      &tam2,tiltc,tilts,tlen,totl,track6d,xpl,xrms,zfz,zpl,zrms,wirel,   &
15821      &acdipph
15822       real hmal
15823       character*16 bez,bezb,bezr,erbez,bezl
15824       character*80 toptit,sixtit,commen
15825       common/erro/ierro,erbez
15826       common/kons/pi,pi2,pisqrt,rad
15827       common/str /il,mper,mblo,mbloz,msym(nper),kanf,iu,ic(nblz)
15828       common/ell /ed(nele),el(nele),ek(nele),sm(nele),kz(nele),kp(nele)
15829       common/pla /xpl(nele),xrms(nele),zpl(nele),zrms(nele)
15830       common/str2 /mel(nblo),mtyp(nblo,nelb),mstr(nblo)
15831       common/mat/a(nele,2,6),bl1(nblo,2,6),bl2(nblo,2,6)
15832       common/syos2/rvf(mpa)
15833       common/tra1/rat,idfor,napx,napxo,numl,niu(2),numlr,nde(2),nwr(4), &
15834      &ird,imc,irew,ntwin,iclo6,iclo6r,iver,ibidu
15835       common/syn/qs,e0,pma,ej(mpa),ejf(mpa),phas0,phas,hsy(3),          &
15836      &crad,hsyc(nele),phasc(nele),dppoff,sigmoff(nblz),tlen,            &
15837      &iicav,itionc(nele),ition,idp,ncy,ixcav
15838       common/corcom/dpscor,sigcor,icode,idam,its6d
15839       common/multi/bk0(nele,mmul),ak0(nele,mmul),                       &
15840      &bka(nele,mmul),aka(nele,mmul)
15841       common/mult1/benki,benkc(nele),r00(nele),irm(nele),nmu(nele)
15842       common/rand0/zfz(nzfz),iorg,mzu(nblz),bezr(3,nele),izu0,mmac,mcut
15843       common/rand1/exterr(nblz,40),extalign(nblz,3),tiltc(nblz),        &
15844      &tilts(nblz),mout2,icext(nblz),icextal(nblz)
15845       common/beo /aper(2),di0(2),dip0(2),ta(6,6)
15846       common/clo/dma,dmap,dkq,dqq,de0,ded,dsi,dech,dsm0,itco,itcro,itqv,&
15847      &iout
15848       common/qmodi/qw0(3),amp0,iq(3),iqmod,kpa(nele),iqmod6
15849       common/linop/bez(nele),elbe(nblo),bezb(nblo),ilin,nt,iprint,      &
15850      &ntco,eui,euii,nlin,bezl(nele)
15851       common/cororb/betam(nmon1,2),pam(nmon1,2),betac(ncor1,2),         &
15852      &pac(ncor1,2),bclorb(nmon1,2),nhmoni,nhcorr,nvmoni,nvcorr,         &
15853      &ncororb(nele)
15854       common/apert/apx(nele),apz(nele),ape(3,nele)
15855       common/clos/sigma0(2),iclo,ncorru,ncorrep
15856       common/combin/icomb0(20),icomb(ncom,20),ratio(ncom,20),           &
15857      &ratioe(nele),iratioe(nele),icoe
15858       common/seacom/ise,mesa,mp,m21,m22,m23,ise1,ise2,ise3,isea(nele)
15859       common/subres/qxt,qzt,tam1,tam2,isub,nta,nte,ipt,totl
15860       common/secom/rtc(9,18,10,5),rts(9,18,10,5),ire(12),ipr(5),irmod2
15861       common/secom1/dtr(10),nre,nur,nch,nqc,npp,nrr(5),nu(5)
15862       common/postr/dphix,dphiz,qx0,qz0,dres,dfft,cma1,cma2,             &
15863      &nstart,nstop,iskip,iconv,imad
15864       common/posti1/ipos,iav,iwg,ivox,ivoz,ires,ifh,toptit(5)
15865       common/posti2/kwtype,itf,icr,idis,icow,istw,iffw,nprint,ndafi
15866       common/ripp/irip,irco,ramp(nele),rfre(nele),rzph(nele),nrel(nele)
15867       common/ripp2/nrturn
15868       common/skew/qwsk(2),betx(2),betz(2),alfx(2),alfz(2),iskew,nskew(6)
15869       common/pawc/hmal(nplo)
15870       common/tit/sixtit,commen,ithick
15871       common/co6d/clo6(3),clop6(3)
15872       common/dkic/dki(nele,3)
15873       common/beam/sigman(2,nbb),sigman2(2,nbb),sigmanq(2,nbb),          &
15874      &clobeam(6,nbb),beamoff(6,nbb),parbe(nele,4),track6d(6,npart),     &
15875      &ptnfac(nele),sigz,sige,partnum,parbe14,emitx,emity,emitz,gammar,  &
15876      &nbeam,ibbc,ibeco,ibtyp,lhc
15877       common/trom/ cotr(ntr,6),rrtr(ntr,6,6),imtr(nele)
15878       common/bb6d/ bbcu(nbb,12),ibb6d,imbb(nblz)
15879       common/wireco/ wirel(nele)
15880       common/acdipco/ acdipph(nele), nturn1(nele), nturn2(nele),        &
15881      &nturn3(nele), nturn4(nele)
15882       integer idz,itra
15883       double precision al,as,chi0,chid,dp1,dps,exz,sigm
15884       common/syos/as(6,2,npart,nele),al(6,2,npart,nele),sigm(mpa),      &
15885      &dps(mpa),idz(2)
15886       common/anf/chi0,chid,exz(2,6),dp1,itra
15887       integer ichrom,is
15888       double precision alf0,amp,bet0,clo,clop,cro,x,y
15889       common/tra/x(mpa,2),y(mpa,2),amp(2),bet0(2),alf0(2),clo(2),clop(2)
15890       common/chrom/cro(2),is(2),ichrom
15891       integer icorr,idial,idptr,imod1,imod2,inorm,ipar,namp,ncor,nctype,&
15892      &ndimf,nmom,nmom1,nmom2,nord,nord1,nordf,nsix,nvar,nvar2,nvarf
15893       double precision dpmax,preda,weig1,weig2
15894       character*16 coel
15895       common/dial/preda,idial,nord,nvar,nvar2,nsix,ncor,ipar(mcor)
15896       common/norf/nordf,nvarf,nord1,ndimf,idptr,inorm,imod1,imod2
15897       common/tcorr/icorr,nctype,namp,nmom,nmom1,nmom2,weig1,weig2,dpmax,&
15898      &coel(10)
15899       double precision aai,ampt,bbi,damp,rfres,rsmi,rzphs,smi,smizf,xsi,&
15900      &zsi
15901       real tlim,time0,time1
15902       common/xz/xsi(nblz),zsi(nblz),smi(nblz),smizf(nblz),              &
15903      &aai(nblz,mmul),bbi(nblz,mmul)
15904       common/rfres/rsmi(nblz),rfres(nblz),rzphs(nblz)
15905       common/damp/damp,ampt
15906       common/ttime/tlim,time0,time1
15907       double precision tasm
15908       common/tasm/tasm(6,6)
15909       integer iv,ixv,nlostp,nms,numxv
15910       double precision aaiv,aek,afok,alf0v,ampv,aperv,as3,as4,as6,bbiv, &
15911      &bet0v,bl1v,ci,clo0,clo6v,cloau,clop0,clop6v,clopv,clov,co,cr,dam, &
15912      &di0au,di0xs,di0zs,dip0xs,dip0zs,dp0v,dpd,dpsq,dpsv,dpsv6,dpsvl,   &
15913      &ejf0v,ejfv,ejv,ejvl,ekk,ekkv,ekv,eps,epsa,fake,fi,fok,fok1,fokqv, &
15914      &g,gl,hc,hi,hi1,hm,hp,hs,hv,oidpsv,qw,qwc,qwcs,rho,rhoc,rhoi,rvv,  &
15915      &si,sigmv,sigmv6,sigmvl,siq,sm1,sm12,sm2,sm23,sm3,smiv,tas,        &
15916      &tasau,tau,wf,wfa,wfhi,wx,x1,x2,xau,xlv,xsiv,xsv,xv,xvl,yv,yvl,zlv,&
15917      &zsiv,zsv
15918       logical pstop
15919       common/main1/                                                     &
15920      &ekv(npart,nele),fokqv(npart),aaiv(mmul,nmac,nblz),                &
15921      &bbiv(mmul,nmac,nblz),smiv(nmac,nblz),zsiv(nmac,nblz),             &
15922      &xsiv(nmac,nblz),xsv(npart),zsv(npart),qw(2),qwc(3),clo0(2),       &
15923      &clop0(2),eps(2),epsa(2),ekk(2),cr(mmul),ci(mmul),xv(2,npart),     &
15924      &yv(2,npart),dam(npart),ekkv(npart),sigmv(npart),dpsv(npart),      &
15925      &dp0v(npart),sigmv6(npart),dpsv6(npart),ejv(npart),ejfv(npart),    &
15926      &xlv(npart),zlv(npart),pstop(npart),rvv(npart),                    &
15927      &ejf0v(npart),numxv(npart),nms(npart),nlostp(npart)
15928       common/main2/ dpd(npart),dpsq(npart),fok(npart),rho(npart),       &
15929      &fok1(npart),si(npart),co(npart),g(npart),gl(npart),sm1(npart),    &
15930      &sm2(npart),sm3(npart),sm12(npart),as3(npart),as4(npart),          &
15931      &as6(npart),sm23(npart),rhoc(npart),siq(npart),aek(npart),         &
15932      &afok(npart),hp(npart),hm(npart),hc(npart),hs(npart),wf(npart),    &
15933      &wfa(npart),wfhi(npart),rhoi(npart),hi(npart),fi(npart),hi1(npart),&
15934      &xvl(2,npart),yvl(2,npart),ejvl(npart),dpsvl(npart),oidpsv(npart), &
15935      &sigmvl(npart),iv(npart),aperv(npart,2),ixv(npart),clov(2,npart),  &
15936      &clopv(2,npart),alf0v(npart,2),bet0v(npart,2),ampv(npart)
15937       common/main3/ clo6v(3,npart),clop6v(3,npart),hv(6,2,npart,nblo),  &
15938      &bl1v(6,2,npart,nblo),tas(npart,6,6),qwcs(npart,3),di0xs(npart),   &
15939      &di0zs(npart),dip0xs(npart),dip0zs(npart),xau(2,6),cloau(6),       &
15940      &di0au(4),tau(6,6),tasau(npart,6,6),wx(3),x1(6),x2(6),fake(2,20)
15941       integer numx
15942       double precision e0f
15943       common/main4/ e0f,numx
15944       integer ktrack,nwri
15945       double precision dpsv1,strack,strackc,stracks
15946       common/track/ ktrack(nblz),strack(nblz),strackc(nblz),            &
15947      &stracks(nblz),dpsv1(npart),nwri
15948       save
15949 !---------------------------------------  SUBROUTINE 'ENVARS' IN-LINE
15950       do 10 j=1,napx
15951         dpd(j)=one+dpsv(j)
15952         dpsq(j)=sqrt(dpd(j))
15953 !
15954    10 continue
15955       do 160 l=1,il
15956         if(abs(el(l)).le.pieni) goto 160
15957         kz1=kz(l)+1
15958         goto(20,40,80,60,40,60,100,100,140),kz1
15959         goto 160
15960 !-----------------------------------------------------------------------
15961 !  DRIFTLENGTH
15962 !-----------------------------------------------------------------------
15963    20   do 30 j=1,napx
15964           as(6,1,j,l)=-rvv(j)*el(l)/c2e3
15965           as(6,2,j,l)=as(6,1,j,l)
15966           as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
15967    30   continue
15968         goto 160
15969 !-----------------------------------------------------------------------
15970 !  RECTANGULAR MAGNET
15971 !  HORIZONTAL
15972 !-----------------------------------------------------------------------
15973    40   fokm=el(l)*ed(l)
15974         if(abs(fokm).le.pieni) goto 20
15975         if(kz1.eq.2) then
15976           ih1=1
15977           ih2=2
15978         else
15979 !  RECTANGULAR MAGNET VERTICAL
15980           ih1=2
15981           ih2=1
15982         endif
15983         do 50 j=1,napx
15984           fok(j)=fokm/dpsq(j)
15985           rho(j)=(one/ed(l))*dpsq(j)
15986           fok1(j)=(tan(fok(j)*half))/rho(j)
15987           si(j)=sin(fok(j))
15988           co(j)=cos(fok(j))
15989           al(2,ih1,j,l)=rho(j)*si(j)
15990           al(5,ih1,j,l)=-dpsv(j)*(rho(j)*(one-co(j))/dpsq(j))*c1e3
15991           al(6,ih1,j,l)=-dpsv(j)*(two*tan(fok(j)*half)/dpsq(j))*c1e3
15992           sm1(j)=cos(fok(j))
15993           sm2(j)=sin(fok(j))*rho(j)
15994           sm3(j)=-sin(fok(j))/rho(j)
15995           sm12(j)=el(l)-sm1(j)*sm2(j)
15996           sm23(j)=sm2(j)*sm3(j)
15997           as3(j)=-rvv(j)*(dpsv(j)*rho(j)/(two*dpsq(j))*sm23(j)- rho(j)  &
15998      &*dpsq(j)*(one-sm1(j)))
15999           as4(j)=-rvv(j)*sm23(j)/c2e3
16000           as6(j)=-rvv(j)*(el(l)+sm1(j)*sm2(j))/c4e3
16001           as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j)+&
16002      &dpsv(j)*(el(l)-sm2(j)))+el(l)*(one-rvv(j)))*c1e3
16003           as(2,ih1,j,l)=-rvv(j)*(dpsv(j)/(two*rho(j)*dpsq(j))*sm12(j)-  &
16004      &sm2(j)*dpsq(j)/rho(j))+fok1(j)*as3(j)
16005           as(3,ih1,j,l)=as3(j)
16006           as(4,ih1,j,l)=as4(j)+two*as6(j)*fok1(j)
16007           as(5,ih1,j,l)=-rvv(j)*sm12(j)/(c4e3*rho(j)*rho(j))+ as6(j)    &
16008      &*fok1(j)*fok1(j)+fok1(j)*as4(j)
16009           as(6,ih1,j,l)=as6(j)
16010 !--VERTIKAL
16011           g(j)=tan(fok(j)*half)/rho(j)
16012           gl(j)=el(l)*g(j)
16013           al(1,ih2,j,l)=one-gl(j)
16014           al(3,ih2,j,l)=-g(j)*(two-gl(j))
16015           al(4,ih2,j,l)=al(1,ih2,j,l)
16016           as6(j)=-rvv(j)*al(2,ih2,j,l)/c2e3
16017           as(4,ih2,j,l)=-two*as6(j)*fok1(j)
16018           as(5,ih2,j,l)=as6(j)*fok1(j)*fok1(j)
16019           as(6,ih2,j,l)=as6(j)
16020    50   continue
16021         goto 160
16022 !-----------------------------------------------------------------------
16023 !  SEKTORMAGNET
16024 !  HORIZONTAL
16025 !-----------------------------------------------------------------------
16026    60   fokm=el(l)*ed(l)
16027         if(abs(fokm).le.pieni) goto 20
16028         if(kz1.eq.4) then
16029           ih1=1
16030           ih2=2
16031         else
16032 !  SECTOR MAGNET VERTICAL
16033           ih1=2
16034           ih2=1
16035         endif
16036         do 70 j=1,napx
16037           fok(j)=fokm/dpsq(j)
16038           rho(j)=(one/ed(l))*dpsq(j)
16039           si(j)=sin(fok(j))
16040           co(j)=cos(fok(j))
16041           rhoc(j)=rho(j)*(one-co(j))/dpsq(j)
16042           siq(j)=si(j)/dpsq(j)
16043           al(1,ih1,j,l)=co(j)
16044           al(2,ih1,j,l)=rho(j)*si(j)
16045           al(3,ih1,j,l)=-si(j)/rho(j)
16046           al(4,ih1,j,l)=co(j)
16047           al(5,ih1,j,l)=-dpsv(j)*rhoc(j)*c1e3
16048           al(6,ih1,j,l)=-dpsv(j)*siq(j)*c1e3
16049           sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16050           sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16051           as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j) &
16052      &+dpsv(j)*(el(l)-al(2,ih1,j,l)))+el(l)*(one-rvv(j)))*c1e3
16053           as(2,ih1,j,l)=-rvv(j)*(dpsv(j)/(two*rho(j)*dpsq(j))*sm12(j)-  &
16054      &dpd(j)*siq(j))
16055           as(3,ih1,j,l)=-rvv(j)*(dpsv(j)*rho(j)/(two*dpsq(j))*sm23(j)-  &
16056      &dpd(j)*rhoc(j))
16057           as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16058           as(5,ih1,j,l)=-rvv(j)*sm12(j)/(c4e3*rho(j)*rho(j))
16059           as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l))/c4e3
16060 !--VERTIKAL
16061           as(6,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)/c2e3
16062    70   continue
16063         goto 160
16064 !-----------------------------------------------------------------------
16065 !  QUADRUPOLE
16066 !  FOCUSSING
16067 !-----------------------------------------------------------------------
16068    80   do 90 j=1,napx
16069           fok(j)=ekv(j,l)*oidpsv(j)
16070           aek(j)=abs(fok(j))
16071           hi(j)=sqrt(aek(j))
16072           fi(j)=el(l)*hi(j)
16073           if(fok(j).le.zero) then
16074             al(1,1,j,l)=cos(fi(j))
16075             hi1(j)=sin(fi(j))
16076             if(abs(hi(j)).le.pieni) then
16077               al(2,1,j,l)=el(l)
16078             else
16079               al(2,1,j,l)=hi1(j)/hi(j)
16080             endif
16081             al(3,1,j,l)=-hi1(j)*hi(j)
16082             al(4,1,j,l)=al(1,1,j,l)
16083             as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
16084             as(4,1,j,l)=-rvv(j)*al(2,1,j,l)*al(3,1,j,l)/c2e3
16085             as(5,1,j,l)=-rvv(j)*(el(l)-al(1,1,j,l)*al(2,1,j,l))* aek(j) &
16086      &/c4e3
16087             as(6,1,j,l)=-rvv(j)*(el(l)+al(1,1,j,l)*al(2,1,j,l))/c4e3
16088 !--DEFOCUSSING
16089             hp(j)=exp(fi(j))
16090             hm(j)=one/hp(j)
16091             hc(j)=(hp(j)+hm(j))*half
16092             hs(j)=(hp(j)-hm(j))*half
16093             al(1,2,j,l)=hc(j)
16094             if(abs(hi(j)).le.pieni) then
16095               al(2,2,j,l)=el(l)
16096             else
16097               al(2,2,j,l)=hs(j)/hi(j)
16098             endif
16099             al(3,2,j,l)=hs(j)*hi(j)
16100             al(4,2,j,l)=hc(j)
16101             as(4,2,j,l)=-rvv(j)*al(2,2,j,l)*al(3,2,j,l)/c2e3
16102             as(5,2,j,l)=+rvv(j)*(el(l)-al(1,2,j,l)*al(2,2,j,l))* aek(j) &
16103      &/c4e3
16104             as(6,2,j,l)=-rvv(j)*(el(l)+al(1,2,j,l)*al(2,2,j,l))/c4e3
16105           else
16106             al(1,2,j,l)=cos(fi(j))
16107             hi1(j)=sin(fi(j))
16108             if(abs(hi(j)).le.pieni) then
16109               al(2,2,j,l)=el(l)
16110             else
16111               al(2,2,j,l)=hi1(j)/hi(j)
16112             endif
16113             al(3,2,j,l)=-hi1(j)*hi(j)
16114             al(4,2,j,l)=al(1,2,j,l)
16115             as(1,2,j,l)=el(l)*(one-rvv(j))*c1e3
16116             as(4,2,j,l)=-rvv(j)*al(2,2,j,l)*al(3,2,j,l)/c2e3
16117             as(5,2,j,l)=-rvv(j)*(el(l)-al(1,2,j,l)*al(2,2,j,l))* aek(j) &
16118      &/c4e3
16119             as(6,2,j,l)=-rvv(j)*(el(l)+al(1,2,j,l)*al(2,2,j,l))/c4e3
16120 !--DEFOCUSSING
16121             hp(j)=exp(fi(j))
16122             hm(j)=one/hp(j)
16123             hc(j)=(hp(j)+hm(j))*half
16124             hs(j)=(hp(j)-hm(j))*half
16125             al(1,1,j,l)=hc(j)
16126             if(abs(hi(j)).le.pieni) then
16127               al(2,1,j,l)=el(l)
16128             else
16129               al(2,1,j,l)=hs(j)/hi(j)
16130             endif
16131             al(3,1,j,l)=hs(j)*hi(j)
16132             al(4,1,j,l)=hc(j)
16133             as(4,1,j,l)=-rvv(j)*al(2,1,j,l)*al(3,1,j,l)/c2e3
16134             as(5,1,j,l)=+rvv(j)*(el(l)-al(1,1,j,l)*al(2,1,j,l))* aek(j) &
16135      &/c4e3
16136             as(6,1,j,l)=-rvv(j)*(el(l)+al(1,1,j,l)*al(2,1,j,l))/c4e3
16137           endif
16138    90   continue
16139         goto 160
16140 !-----------------------------------------------------------------------
16141 !  COMBINED FUNCTION MAGNET HORIZONTAL
16142 !  FOCUSSING
16143 !-----------------------------------------------------------------------
16144   100   if(kz1.eq.7) then
16145           do 110 j=1,napx
16146             fokqv(j)=ekv(j,l)
16147   110     continue
16148           ih1=1
16149           ih2=2
16150         else
16151 !  COMBINED FUNCTION MAGNET VERTICAL
16152           do 120 j=1,napx
16153             fokqv(j)=-ekv(j,l)
16154   120     continue
16155           ih1=2
16156           ih2=1
16157         endif
16158         do 130 j=1,napx
16159           wf(j)=ed(l)/dpsq(j)
16160           fok(j)=fokqv(j)/dpd(j)-wf(j)*wf(j)
16161           afok(j)=abs(fok(j))
16162           hi(j)=sqrt(afok(j))
16163           fi(j)=hi(j)*el(l)
16164           if(afok(j).le.pieni) then
16165             as(6,1,j,l)=-rvv(j)*el(l)/c2e3
16166             as(6,2,j,l)=as(6,1,j,l)
16167             as(1,1,j,l)=el(l)*(one-rvv(j))*c1e3
16168           endif
16169           if(fok(j).lt.-pieni) then
16170             si(j)=sin(fi(j))
16171             co(j)=cos(fi(j))
16172             wfa(j)=wf(j)/afok(j)*(one-co(j))/dpsq(j)
16173             wfhi(j)=wf(j)/hi(j)*si(j)/dpsq(j)
16174             al(1,ih1,j,l)=co(j)
16175             al(2,ih1,j,l)=si(j)/hi(j)
16176             al(3,ih1,j,l)=-si(j)*hi(j)
16177             al(4,ih1,j,l)=co(j)
16178             al(5,ih1,j,l)=-wfa(j)*dpsv(j)*c1e3
16179             al(6,ih1,j,l)=-wfhi(j)*dpsv(j)*c1e3
16180             sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16181             sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16182             as(1,ih1,j,l)=(-rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12  &
16183      &(j)+ dpsv(j)*(el(l)-al(2,ih1,j,l)))/afok(j)*wf(j)*wf(j)+el        &
16184      &(l)* (one-rvv(j)))*c1e3
16185             as(2,ih1,j,l)=-rvv(j)*(dpsv(j)*wf(j)/(two*dpsq(j))*sm12(j)- &
16186      &dpd(j)*wfhi(j))
16187             as(3,ih1,j,l)=-rvv(j)*(dpsv(j)*half/afok(j)/dpd(j)* ed(l)   &
16188      &*sm23(j)-dpd(j)*wfa(j))
16189             as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16190             as(5,ih1,j,l)=-rvv(j)*sm12(j)*afok(j)/c4e3
16191             as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l))   &
16192      &/c4e3
16193             aek(j)=abs(ekv(j,l)/dpd(j))
16194             hi(j)=sqrt(aek(j))
16195             fi(j)=hi(j)*el(l)
16196             hp(j)=exp(fi(j))
16197             hm(j)=one/hp(j)
16198             hc(j)=(hp(j)+hm(j))*half
16199             hs(j)=(hp(j)-hm(j))*half
16200             al(1,ih2,j,l)=hc(j)
16201             if(abs(hi(j)).gt.pieni) al(2,ih2,j,l)=hs(j)/hi(j)
16202             al(3,ih2,j,l)=hs(j)*hi(j)
16203             al(4,ih2,j,l)=hc(j)
16204             as(4,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)*al(3,ih2,j,l)/c2e3
16205             as(5,ih2,j,l)=+rvv(j)*(el(l)-al(1,ih2,j,l)*al(2,ih2,j,l))*  &
16206      &aek(j)/c4e3
16207             as(6,ih2,j,l)=-rvv(j)*(el(l)+al(1,ih2,j,l)*al(2,ih2,j,l))   &
16208      &/c4e3
16209           endif
16210 !--DEFOCUSSING
16211           if(fok(j).gt.pieni) then
16212             hp(j)=exp(fi(j))
16213             hm(j)=one/hp(j)
16214             hc(j)=(hp(j)+hm(j))*half
16215             hs(j)=(hp(j)-hm(j))*half
16216             al(1,ih1,j,l)=hc(j)
16217             al(2,ih1,j,l)=hs(j)/hi(j)
16218             al(3,ih1,j,l)=hs(j)*hi(j)
16219             al(4,ih1,j,l)=hc(j)
16220             wfa(j)=wf(j)/afok(j)*(one-hc(j))/dpsq(j)
16221             wfhi(j)=wf(j)/hi(j)*hs(j)/dpsq(j)
16222             al(5,ih1,j,l)= wfa(j)*dpsv(j)*c1e3
16223             al(6,ih1,j,l)=-wfhi(j)*dpsv(j)*c1e3
16224             sm12(j)=el(l)-al(1,ih1,j,l)*al(2,ih1,j,l)
16225             sm23(j)=al(2,ih1,j,l)*al(3,ih1,j,l)
16226             as(1,ih1,j,l)=(rvv(j)*(dpsv(j)*dpsv(j)/(four*dpd(j))*sm12(j)&
16227      &+dpsv(j)*(el(l)-al(2,ih1,j,l)))/afok(j)*wf(j)*wf(j)+el(l)*        &
16228      &(one-rvv(j)))*c1e3
16229             as(2,ih1,j,l)=-rvv(j)*(dpsv(j)*wf(j)/(two*dpsq(j))*sm12(j)- &
16230      &dpd(j)*wfhi(j))
16231             as(3,ih1,j,l)=rvv(j)*(dpsv(j)*half/afok(j)/dpd(j)* ed(l)    &
16232      &*sm23(j)-dpd(j)*wfa(j))
16233             as(4,ih1,j,l)=-rvv(j)*sm23(j)/c2e3
16234             as(5,ih1,j,l)=+rvv(j)*sm12(j)*afok(j)/c4e3
16235             as(6,ih1,j,l)=-rvv(j)*(el(l)+al(1,ih1,j,l)*al(2,ih1,j,l))   &
16236      &/c4e3
16237             aek(j)=abs(ekv(j,l)/dpd(j))
16238             hi(j)=sqrt(aek(j))
16239             fi(j)=hi(j)*el(l)
16240             si(j)=sin(fi(j))
16241             co(j)=cos(fi(j))
16242             al(1,ih2,j,l)=co(j)
16243             al(2,ih2,j,l)=si(j)/hi(j)
16244             al(3,ih2,j,l)=-si(j)*hi(j)
16245             al(4,ih2,j,l)=co(j)
16246             as(4,ih2,j,l)=-rvv(j)*al(2,ih2,j,l)*al(3,ih2,j,l)/c2e3
16247             as(5,ih2,j,l)=-rvv(j)*(el(l)-al(1,ih2,j,l)*al(2,ih2,j,l))*  &
16248      &aek(j)/c4e3
16249             as(6,ih2,j,l)=-rvv(j)*(el(l)+al(1,ih2,j,l)*al(2,ih2,j,l))   &
16250      &/c4e3
16251           endif
16252   130   continue
16253         goto 160
16254 !-----------------------------------------------------------------------
16255 !  EDGE FOCUSSING
16256 !-----------------------------------------------------------------------
16257   140   do 150 j=1,napx
16258           rhoi(j)=ed(l)/dpsq(j)
16259           fok(j)=rhoi(j)*tan(el(l)*rhoi(j)*half)
16260           al(3,1,j,l)=fok(j)
16261           al(3,2,j,l)=-fok(j)
16262   150   continue
16263   160 continue
16264 !---------------------------------------  END OF 'ENVARS' (2)
16265       return
16266       end
16267       subroutine collimate2(name_coll,
16268      &                      c_material, c_length, c_rotation,           &
16269      &c_aperture, c_offset, c_tilt,x_in, xp_in, y_in,yp_in,p_in, s_in,  &
16270      &np, enom, lhit,part_abs, impact, indiv, lint, onesided, name,     &
16271      &flagsec, j_slices)
16272 !MAY2005
16273 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16274 !----                                                                    -----
16275 !-----  NEW ROUTINES PROVIDED FOR THE COLLIMATION STUDIES VIA SIXTRACK   -----
16276 !-----                                                                   -----
16277 !-----          G. ROBERT-DEMOLAIZE, November 1st, 2004                  -----
16278 !-----                                                                   -----
16279 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16280 !
16281 !
16282 !++  Based on routines by JBJ. Changed by RA 2001.
16283 !
16284 !
16285 !GRD
16286 !GRD MODIFIED VERSION FOR COLLIMATION SYSTEM: G. ROBERT-DEMOLAIZE
16287 !GRD
16288 !
16289 !++  - Deleted all HBOOK stuff.
16290 !++  - Deleted optics routine and all parser routines.
16291 !++  - Replaced RANMAR call by RANLUX call
16292 !++  - Included RANLUX code from CERNLIB into source
16293 !++  - Changed dimensions from CGen(100,nmat) to CGen(200,nmat)
16294 !++  - Replaced FUNPRE with FUNLXP
16295 !++  - Replaced FUNRAN with FUNLUX
16296 !++  - Included all CERNLIB code into source: RANLUX, FUNLXP, FUNLUX,
16297 !++                                         FUNPCT, FUNLZ, RADAPT,
16298 !++                                           RGS56P
16299 !++    with additional entries:             RLUXIN, RLUXUT, RLUXAT,
16300 !++                                           RLUXGO
16301 !++
16302 !++  - Changed program so that Nev is total number of particles
16303 !++    (scattered and not-scattered)
16304 !++  - Added debug comments
16305 !++  - Put real dp/dx
16306 !
16307       implicit none
16308 !
16309       character*16 name_coll
16310       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
16311      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
16312      &nrco,ntr,nzfz
16313       parameter(npart = 64,nmac = 1)
16314       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
16315      &nzfz = 300000,mmul = 11)
16316       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
16317      &nema = 15)
16318       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
16319       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
16320       parameter(nmon1 = 600,ncor1 = 600)
16321       parameter(ntr = 20,nbb = 160)
16322       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
16323 !UPGRADE January 2005
16324 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
16325       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
16326      &maxn=20000,outlun=54)
16327 !
16328 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
16329 !
16330       integer ipencil
16331       double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll),       &
16332      &y_pencil(max_ncoll),pencil_dx(max_ncoll)
16333       common  /pencil/  xp_pencil0,yp_pencil0,pencil_dx,ipencil
16334       common  /pencil2/ x_pencil, y_pencil
16335 !
16336 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16337 !
16338       integer ie,iturn,nabs_total
16339       common  /info/ ie,iturn,nabs_total
16340 !
16341 !
16342       logical onesided,hit
16343       integer nprim,filel,mat,nev,j,nabs,nhit,np,icoll
16344 !MAY2005
16345 !      integer lhit(npart),part_abs(npart)
16346       integer lhit(npart),part_abs(npart),name(npart)
16347 !MAY2005
16348       double precision p0,xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax   &
16349      &,length,zlm,x,x00,xp,z,z00,zp,p,sp,dpop,s,enom,x_in(npart),       &
16350      &xp_in(npart),y_in(npart),yp_in(npart),p_in(npart),s_in(npart),    &
16351      &indiv(npart),lint(npart),x_out(max_npart),xp_out(max_npart),      &
16352      &y_out(max_npart),yp_out(max_npart),p_out(max_npart),              &
16353      &s_out(max_npart),keeps,fracab,mybetax,mybetaz,mymux,mymuz,sigx,   &
16354      &sigz,norma,xpmu,atdi,drift_length,mirror,tiltangle,impact(npart)
16355 !
16356       double precision c_length    !length in m
16357       double precision c_rotation  !rotation angle vs vertical in radian
16358       double precision c_aperture  !aperture in m
16359       double precision c_offset    !offset in m
16360       double precision c_tilt(2)   !tilt in radian
16361       character*6      c_material  !material
16362 !
16363 !
16364 !
16365       character*(nc) filen,tit
16366 !
16367       real   rndm4,xlow,xhigh,xplow,xphigh,dx,dxp
16368 !
16369 !AUGUST2006 Added ran_gauss for generation of pencil/     ------- TW
16370 !           sheet beam distribution  (smear in x and y)
16371 !
16372       double precision ran_gauss
16373 !
16374       common /cmom/xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax,length,  &
16375      &nev
16376       common /materia/mat
16377       common /phase/x,xp,z,zp,dpop
16378       common /nommom/p0
16379       common /cjaw1/zlm
16380       common /other/mybetax,mybetaz,mymux,mymuz,atdi
16381       common /icoll/  icoll
16382 !
16383       data   dx,dxp/.5d-4,20.d-4/
16384 !
16385 !
16386 !
16387 !GRD
16388 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
16389 !GRD
16390 !APRIL2005
16391       logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside,     &
16392      &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial,        &
16393      &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
16394 !SEPT2005 for slicing process
16395       integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber,         &
16396      &do_thisdis,n_slices,pencil_distr
16397 !JUNE2005
16398       double precision myenom,mynex,mdex,myney,mdey,                    &
16399      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
16400      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
16401 !
16402      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
16403      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
16404 !
16405      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
16406 !SEPT2005 add these lines for the slicing procedure
16407      &smin_slices,smax_slices,recenter1,recenter2,                      &
16408      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
16409      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
16410 !SEPT2005,OCT2006 added offset
16411      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
16412      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
16413      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
16414      &c_sysoffset_sec,c_rmserror_gap,nr,ndr,                            &
16415 !     &driftsx,driftsy,pencil_offset,sigsecut3
16416 !JUNE2005
16417 !     &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
16418      &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,            &
16419      &sigsecut3,sigsecut2,enerror,bunchlength
16420 !JUNE2005
16421 !APRIL2005
16422 !
16423       character*24 name_sel
16424       character*80 coll_db
16425       character*16 castordir
16426 !JUNE2005
16427       character*80 filename_dis
16428 !JUNE2005
16429 !
16430       common /grd/ myenom,mynex,mdex,myney,mdey,                        &
16431      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
16432      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
16433 !
16434      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
16435      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
16436 !
16437      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo,nsig_cry,   &
16438 !
16439      &smin_slices,smax_slices,recenter1,recenter2,                      &
16440      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
16441      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
16442 !
16443      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
16444      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
16445      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
16446      &c_sysoffset_sec,c_rmserror_gap,nr,                                &
16447 !
16448      &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,        &
16449      &sigsecut3,sigsecut2,enerror,                                      &
16450      &bunchlength,coll_db,name_sel,                                     &
16451      &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed,          &
16452      &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr,                 &
16453      &do_coll,                                                          &
16454 !
16455      &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
16456      &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
16457      &dowritetracks,cern,do_nsig,do_mingap
16458 !SEPT2005
16459 !JUNE2005
16460 !APRIL2005
16461 !
16462 !--September 2006 -- TW common to readcollimator and collimate2
16463 !      logical           changed_tilt1(max_ncoll)
16464 !      logical           changed_tilt2(max_ncoll)
16465 !      common /tilt/ changed_tilt1, changed_tilt2
16466 !--September 2006
16467 !
16468 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16469 !
16470 !
16471       double precision x_flk,xp_flk,y_flk,yp_flk
16472 !
16473       double precision s_impact
16474       integer flagsec(maxn)
16475 !
16476 !     SR, 18-08-2005: add temporary variable to write in FirstImpacts
16477 !     the initial distribution of the impacting particles in the
16478 !     collimator frame.
16479       double precision xinn,xpinn,yinn,ypinn
16480 !
16481 !     SR, 29-08-2005: add the slice number to calculate the impact
16482 !     location within the collimator.
16483 !     j_slices = 1 for the a non sliced collimator!
16484       integer j_slices
16485 !
16486       save
16487 !
16488       common /Process/ bool_proc,bool_create
16489       integer  bool_proc(maxn)
16490       logical  bool_create
16491 !=======================================================================
16492 ! Be=1 Al=2 Cu=3 W=4 Pb=5
16493 !
16494 ! LHC uses:    Al, 0.2 m
16495 !              Cu, 1.0 m
16496 !
16497 !      write(*,*) 'enter collimate2 routine'
16498       if (c_material.eq.'BE') then
16499          mat = 1
16500       elseif (c_material.eq.'Be') then
16501          mat = 1
16502       elseif (c_material.eq.'AL') then
16503          mat = 2
16504       elseif (c_material.eq.'Al') then
16505          mat = 2
16506       elseif (c_material.eq.'CU') then
16507          mat = 3
16508       elseif (c_material.eq.'Cu') then
16509          mat = 3
16510       elseif (c_material.eq.'W') then
16511          mat = 4
16512       elseif (c_material.eq.'PB') then
16513          mat = 5
16514       elseif (c_material.eq.'Pb') then
16515          mat = 5
16516       elseif (c_material.eq.'C') then
16517          mat = 6
16518       elseif (c_material.eq.'C2') then
16519          mat = 7
16520 !02/2008 TW added vacuum and black absorber (was missing)
16521       elseif (c_material.eq.'VA') then
16522          mat = 11
16523       elseif (c_material.eq.'BL') then
16524          mat = 12
16525       else
16526          write(*,*) 'ERR>  Material not found. STOP (TW)', c_material
16527 !        STOP
16528       endif
16529 !
16530       length  = c_length
16531       nev = np
16532       p0  = enom
16533 !
16534 !++  Initialize scattering processes
16535 !
16536       call scatin(p0)
16537  
16538 ! EVENT LOOP,  initial distribution is here a flat distribution with
16539 ! xmin=x-, xmax=x+, etc. from the input file
16540 !
16541       nhit    = 0
16542       fracab  = 0d0
16543       mirror  = 1d0
16544 !
16545 !==> SLICE here
16546 !
16547  
16548 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
16549       do j = 1, nev
16550 !
16551 ! SR-GRD (04-08-2005):
16552 !     Don't do scattering process for particles already absorbed
16553         if (part_abs(j) .ne. 0) goto 777
16554         impact(j) = -1d0
16555         lint(j)   = -1d0
16556         indiv(j)  = -1d0
16557         x   = x_in(j)
16558         xp  = xp_in(j)
16559         z   = y_in(j)
16560         zp  = yp_in(j)
16561         p   = p_in(j)
16562         sp   = 0d0
16563         dpop = (p - p0)/p0
16564         x_flk  = 0d0
16565         y_flk  = 0d0
16566         xp_flk = 0d0
16567         yp_flk = 0d0
16568 !
16569 !++  Transform particle coordinates to get into collimator coordinate
16570 !++  system
16571 !
16572 !++  First do rotation into collimator frame
16573 !
16574         x  = x_in(j)*cos(c_rotation) +sin(c_rotation)*y_in(j)
16575         z  = y_in(j)*cos(c_rotation) -sin(c_rotation)*x_in(j)
16576         xp = xp_in(j)*cos(c_rotation)+sin(c_rotation)*yp_in(j)
16577         zp = yp_in(j)*cos(c_rotation)-sin(c_rotation)*xp_in(j)
16578 !
16579 !++  For one-sided collimators consider only positive X. For negative
16580 !++  X jump to the next particle
16581 !
16582         if (name_coll(6:8).eq."SPS") then
16583                 if (x.gt.0) goto 777
16584         else
16585                 if (onesided .and. x.lt.0) goto 777
16586         endif
16587         
16588 !
16589 !++  Now mirror at the horizontal axis for negative X offset
16590 !
16591         if (x.lt.0) then
16592                 mirror = -1d0
16593                 tiltangle = -1d0*c_tilt(2)
16594         endif
16595         if (x.ge.0) then
16596                 mirror = 1d0
16597                 tiltangle = c_tilt(1)
16598         endif
16599         x  = mirror * x
16600         xp = mirror * xp
16601         x  = x - c_aperture/2 - mirror*c_offset
16602 !++  Include collimator tilt
16603         if (tiltangle.gt.0.) then
16604                 xp = xp - tiltangle
16605         endif
16606         if (tiltangle.lt.0.) then
16607                 x  = x + sin(tiltangle) * c_length
16608                 xp = xp - tiltangle
16609         endif
16610 c------------------------------------------------------------------------        
16611 c                            PENCIL BEAM
16612 !++  For selected collimator, first turn reset particle distribution
16613 !++  to simple pencil beam
16614 !
16615 ! -- TW why did I set this to 0, seems to be needed for getting
16616 !       right amplitude => no "tilt" of jaw for the first turn !!!!
16617         nprim = 3
16618         if ( (icoll.eq.ipencil .and. iturn.eq.1) .or. (iturn.eq.1       &
16619      &  .and. ipencil.eq.999 .and. icoll.le.nprim .and.                 &
16620      &  (j.ge.(icoll-1)*nev/nprim) .and. (j.le.(icoll)*nev/nprim))) then
16621 ! -- TW why did I set this to 0, seems to be needed for getting
16622 !       right amplitude => no "tilt" of jaw for the first turn !!!!
16623                 c_tilt(1) = 0d0
16624                 c_tilt(2) = 0d0
16625 !AUGUST2006: Standard pencil beam as implemented by GRD ------- TW
16626                 if (pencil_rmsx.eq.0. .and. pencil_rmsy.eq.0.) then
16627                         x    = pencil_dx(icoll)
16628                         xp   = 0.
16629                         z    = 0.
16630                         zp   = 0.
16631                 endif
16632 !
16633 !AUGUST2006: Rectangular (pencil-beam) sheet-beam with  ------ TW
16634 !            pencil_offset is the rectangulars center
16635 !            pencil_rmsx defines spread of impact parameter
16636 !            pencil_rmsy defines spread parallel to jaw surface
16637 !
16638                 if (pencil_distr.eq.0 .and.(pencil_rmsx.ne.0.           &
16639      &          .or.pencil_rmsy.ne.0.)) then
16640 ! how to assure that all generated particles are on the jaw ?!
16641                         x    = pencil_dx(icoll)                         &
16642      &                  + pencil_rmsx*(rndm4()-0.5)
16643                         xp   = 0.
16644                         z    = pencil_rmsy*(rndm4()-0.5)
16645                         zp   = 0.
16646                 endif
16647 !
16648 !AUGUST2006: Gaussian (pencil-beam) sheet-beam with ------- TW
16649 !            pencil_offset is the mean  gaussian distribution
16650 !            pencil_rmsx defines spread of impact parameter
16651 !            pencil_rmsy defines spread parallel to jaw surface
16652 !
16653                 if (pencil_distr.eq.1 .and.(pencil_rmsx.ne.0.           &
16654      &          .or.pencil_rmsy.ne.0. )) then
16655                         x   =pencil_dx(icoll)+pencil_rmsx*ran_gauss(2d0)
16656 ! all generated particles are on the jaw now
16657                         x    = sqrt(x**2)
16658                         xp   = 0.
16659                         z    = pencil_rmsy*ran_gauss(2d0)
16660                         zp   = 0.
16661                 endif
16662 !AUGUST2006: Gaussian (pencil-beam) sheet-beam with ------- TW
16663 !            pencil_offset is the mean  gaussian distribution
16664 !            pencil_rmsx defines spread of impact parameter
16665 !                        here pencil_rmsx is not gaussian!!!
16666 !            pencil_rmsy defines spread parallel to jaw surface
16667 !
16668                 if (pencil_distr.eq.2 .and.(pencil_rmsx.ne.0.           &
16669      &          .or.pencil_rmsy.ne.0. )) then
16670                         x    = pencil_dx(icoll)                         &
16671      &                  + pencil_rmsx*(rndm4()-0.5)
16672 ! all generated particles are on the jaw now
16673                         x    = sqrt(x**2)
16674                         xp   = 0.
16675                         z    = pencil_rmsy*ran_gauss(2d0)
16676                         zp   = 0.
16677                 endif
16678 !JULY2007: Selection of pos./neg. jaw  implemented by GRD ---- TW
16679 ! ensure that for onesided only particles on pos. jaw are created
16680                 if (onesided) then
16681                         mirror = 1d0
16682                 else
16683                         if(rndm4().lt.0.5) then 
16684                                 mirror = -1d0
16685                         else 
16686                                 mirror = 1d0
16687                         endif
16688                 endif 
16689 ! -- TW SEP07 if c_tilt is set to zero before entering pencil beam
16690 !             section the assigning of the tilt will result in
16691 !             assigning zeros
16692                 if (mirror.lt.0) then
16693                         tiltangle = c_tilt(2)
16694                 else 
16695                         tiltangle = c_tilt(1)
16696                 endif
16697 c       write(9997,'(f10.8,(2x,f10.8),(2x,f10.8),(2x,f10.8)(2x,f10.8))')    
16698 c     &            x, xp, z, zp, tiltangle
16699         endif  !!!!!end of the pencil beam stuff!!!!!
16700 c------------------------------------------------------------------------        
16701 !     SR, 18-08-2005: after finishing the coordinate transformation,
16702 !     or the coordinate manipulations in case of pencil beams,
16703 !     write down the initial coordinates of the impacting particles
16704         xinn  = x
16705         xpinn = xp
16706         yinn  = z
16707         ypinn = zp
16708 !
16709 !++  particle passing above the jaw are discarded => take new event
16710 !++  entering by the face, shorten the length (zlm) and keep track of
16711 !++  entrance longitudinal coordinate (keeps) for histograms
16712 !
16713 !++  The definition is that the collimator jaw is at x>=0.
16714 !
16715 !++  1) Check whether particle hits the collimator
16716 !
16717         hit     =  .false.
16718         s       =  0.
16719         keeps   =  0.
16720         zlm     =  -1d0 * length
16721 !
16722         if (x.ge.0.) then
16723 !
16724 !++  Particle hits collimator and we assume interaction length ZLM equal
16725 !++  to collimator length (what if it would leave collimator after
16726 !++  small length due to angle???)
16727 !
16728                 zlm = length
16729                 impact(j) = x
16730                 indiv(j) = xp
16731         else if (xp.le.0.) then
16732 !++  Particle does not hit collimator. Interaction length ZLM is zero.
16733                 zlm = 0d0
16734         else
16735 !++  Calculate s-coordinate of interaction point
16736                 s = (-1d0*x) / xp
16737                 if (s.le.0) then
16738                         write(*,*) 'S.LE.0 -> This should not happen'
16739                         stop
16740                 endif
16741                 if (s .lt. length) then
16742                         zlm = length - s
16743                         impact(j) = 0d0
16744                         indiv(j) = xp
16745                 else
16746                         zlm = 0d0
16747                 endif
16748         endif
16749 !++  First do the drift part
16750         drift_length = length - zlm
16751         if (drift_length.gt.0.) then
16752                 x  = x + xp* drift_length
16753                 z  = z + zp * drift_length
16754                 sp = sp + drift_length
16755         endif
16756 !++  Now do the scattering part
16757         if (zlm.gt.0.) then
16758                 s_impact = sp
16759                 nhit = nhit + 1
16760                 call jaw(s, nabs)
16761 !JUNE2005 SR+GRD: CREATE A FILE TO CHECK THE VALUES OF IMPACT PARAMETERS
16762 !     SR, 29-08-2005: Add to the longitudinal coordinates the position
16763 !     of the slice beginning
16764                 if(dowrite_impact) then
16765                         if(flagsec(j).eq.0) then
16766                                 write(39,'(i5,1x,i7,1x,i2,1x,i1,
16767      &                          2(1x,f5.3),8(1x,e17.9))')               &
16768      &                          name(j),iturn,icoll,nabs,               &
16769      &                          s_impact + (dble(j_slices)-1)* c_length,&
16770      &                          s+sp + (dble(j_slices)-1) * c_length,   &
16771      &                          xinn,xpinn,yinn,ypinn,                  &
16772      &                          x,xp,z,zp
16773                         endif
16774                 endif
16775                 lhit(j) = 10000*ie + iturn
16776 !++  If particle is absorbed then set x and y to 99.99 mm
16777 !     SR: before assigning new (x,y) for nabs=1, write the
16778 !     inelastic impact file .
16779                 if (nabs.eq.1) then
16780                         if (tiltangle.gt.0.) then
16781                                 x  = x  + tiltangle*(s+sp)
16782                                 xp = xp + tiltangle
16783                         elseif (tiltangle.lt.0.) then
16784                                 xp = xp + tiltangle
16785                                 x  = x - sin(tiltangle)* (length-(s+sp))
16786                         endif
16787                         x = x + c_aperture/2d0 + mirror*c_offset
16788                         x    = mirror * x
16789                         xp   = mirror * xp
16790                         x_flk  = x  *cos(-1d0*c_rotation) +             &
16791      &                  z  *sin(-1d0*c_rotation)
16792                         y_flk  = z  *cos(-1d0*c_rotation) -             &
16793      &                  x  *sin(-1d0*c_rotation)
16794                         xp_flk = xp *cos(-1d0*c_rotation) +             &
16795      &                  zp *sin(-1d0*c_rotation)
16796                         yp_flk = zp *cos(-1d0*c_rotation) -             &
16797      &                  xp *sin(-1d0*c_rotation)
16798 !     SR, 29-08-2005: Include the slice numer!
16799                         if(dowrite_impact) then
16800                         write(48,'(i4,(1x,f6.3),(1x,f8.6),4(1x,e19.10), &
16801      &                  i2,2(1x,i7))')                                  &
16802      &                  icoll,c_rotation,                               &
16803      &                  s + sp + (dble(j_slices)-1) * c_length,         &
16804      &                  x_flk*1d3, xp_flk*1d3, y_flk*1d3, yp_flk*1d3,   &
16805      &                  nabs,name(j),iturn
16806                         write(866,*)
16807      &                  name(j), iturn, icoll, bool_proc(j)
16808                         endif
16809 !     Finally, the actual coordinate change to 99 mm
16810                         fracab = fracab + 1
16811                         x = 99.99d-3
16812                         z = 99.99d-3
16813                         part_abs(j) = 10000*ie + iturn
16814                         lint(j) = zlm
16815                 endif
16816         endif
16817 !
16818 !++  Do the rest drift, if particle left collimator early
16819 !
16820         if (nabs.ne.1 .and. zlm.gt.0.) then
16821                 drift_length = (length-(s+sp))
16822                 if (drift_length.gt.1d-15) then
16823                         x  = x + xp * drift_length
16824                         z  = z + zp * drift_length
16825                         sp = sp + drift_length
16826                 endif
16827                 lint(j) = zlm - drift_length
16828         endif
16829 !
16830 !++  Transform back to particle coordinates with opening and offset
16831         if (x.lt.99.0d-3) then
16832 !++  Include collimator tilt
16833                 if (tiltangle.gt.0.) then
16834                         x  = x  + tiltangle*c_length
16835                         xp = xp + tiltangle
16836                 elseif (tiltangle.lt.0.) then
16837                         x  = x + tiltangle*c_length
16838                         xp = xp + tiltangle
16839                         x  = x - sin(tiltangle) * c_length
16840                 endif
16841 !++  Transform back to particle coordinates with opening and offset
16842                 z00 = z
16843                 x00 = x + mirror*c_offset
16844                 x = x + c_aperture/2d0 + mirror*c_offset
16845 !++  Now mirror at the horizontal axis for negative X offset
16846                 x    = mirror * x
16847                 xp   = mirror * xp
16848 !++  Last do rotation into collimator frame
16849 !
16850                 x_in(j)  = x  *cos(-1d0*c_rotation) +                   &
16851      &          z  *sin(-1d0*c_rotation)
16852                 y_in(j)  = z  *cos(-1d0*c_rotation) -                   &
16853      &          x  *sin(-1d0*c_rotation)
16854                 xp_in(j) = xp *cos(-1d0*c_rotation) +                   &
16855      &          zp *sin(-1d0*c_rotation)
16856                 yp_in(j) = zp *cos(-1d0*c_rotation) -                   &
16857      &          xp *sin(-1d0*c_rotation)
16858 !
16859                 if ( (icoll.eq.ipencil                                  &
16860      &          .and. iturn.eq.1)   .or.                                &
16861      &          (iturn.eq.1 .and. ipencil.eq.999 .and.                  &
16862      &          icoll.le.nprim .and.                                    &
16863      &          (j.ge.(icoll-1)*nev/nprim) .and.                        &
16864      &          (j.le.(icoll)*nev/nprim)                                &
16865      &          )  ) then
16866 !
16867                         x00  = mirror * x00
16868                         x_in(j)  = x00  *cos(-1d0*c_rotation) +         &
16869      &                  z00  *sin(-1d0*c_rotation)
16870                         y_in(j)  = z00  *cos(-1d0*c_rotation) -         &
16871      &                  x00  *sin(-1d0*c_rotation)
16872 !
16873                         xp_in(j) = xp_in(j) + mirror*xp_pencil0
16874                         yp_in(j) = yp_in(j) + mirror*yp_pencil0
16875                         x_in(j) = x_in(j) + mirror*x_pencil(icoll)
16876                         y_in(j) = y_in(j) + mirror*y_pencil(icoll)
16877                 endif
16878                 p_in(j) = (1d0 + dpop) * p0
16879 !     SR, 30-08-2005: add the initial position of the slice
16880                 s_in(j) = sp + (dble(j_slices)-1) * c_length
16881         else
16882                 x_in(j)  = x
16883                 y_in(j)  = z
16884         endif
16885  777  end do
16886 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
16887 !
16888 !      WRITE(*,*) 'Number of particles:            ', Nev
16889 !      WRITE(*,*) 'Number of particle hits:        ', Nhit
16890 !      WRITE(*,*) 'Number of absorped particles:   ', fracab
16891 !      WRITE(*,*) 'Number of escaped particles:    ', Nhit-fracab
16892 !      WRITE(*,*) 'Fraction of absorped particles: ', 100.*fracab/Nhit
16893 !
16894       end
16895 !
16896 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
16897 !
16898       subroutine collimaterhic(c_material, c_length, c_rotation,        &
16899 !JUNE2005
16900      &c_aperture, n_aperture,                                           &
16901 !JUNE2005
16902      &c_offset, c_tilt,                                                 &
16903      &x_in, xp_in, y_in,                                                &
16904      &yp_in, p_in, s_in, np, enom, lhit,                                &
16905 !     &part_abs, impact, indiv, lint, onesided)
16906      &part_abs, impact, indiv, lint, onesided,                          &
16907      &name)
16908 !
16909 !++  Based on routines by JBJ. Changed by RA 2001.
16910 !
16911 !++  - Deleted all HBOOK stuff.
16912 !++  - Deleted optics routine and all parser routines.
16913 !++  - Replaced RANMAR call by RANLUX call
16914 !++  - Included RANLUX code from CERNLIB into source
16915 !++  - Changed dimensions from CGen(100,nmat) to CGen(200,nmat)
16916 !++  - Replaced FUNPRE with FUNLXP
16917 !++  - Replaced FUNRAN with FUNLUX
16918 !++  - Included all CERNLIB code into source: RANLUX, FUNLXP, FUNLUX,
16919 !++                                         FUNPCT, FUNLZ, RADAPT,
16920 !++                                           RGS56P
16921 !++    with additional entries:             RLUXIN, RLUXUT, RLUXAT,
16922 !++                                           RLUXGO
16923 !++
16924 !++  - Changed program so that Nev is total number of particles
16925 !++    (scattered and not-scattered)
16926 !++  - Added debug comments
16927 !++  - Put real dp/dx
16928 !
16929       implicit none
16930 !
16931       double precision sx, sz
16932 !
16933       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
16934      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
16935      &nrco,ntr,nzfz
16936       parameter(npart = 64,nmac = 1)
16937       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
16938      &nzfz = 300000,mmul = 11)
16939       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
16940      &nema = 15)
16941       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
16942       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
16943       parameter(nmon1 = 600,ncor1 = 600)
16944       parameter(ntr = 20,nbb = 160)
16945       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
16946 !UPGRADE January 2005
16947 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
16948       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
16949      &maxn=20000,outlun=54)
16950 !
16951 ! THIS BLOCK IS COMMON TO THIN6D, TRAUTHIN, COLLIMATE32 AND MAINCR
16952 !
16953       integer ipencil
16954       double precision xp_pencil0,yp_pencil0,x_pencil(max_ncoll),       &
16955      &y_pencil(max_ncoll),pencil_dx(max_ncoll)
16956       common  /pencil/  xp_pencil0,yp_pencil0,pencil_dx,ipencil
16957       common  /pencil2/ x_pencil, y_pencil
16958 !
16959 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
16960 !
16961       integer ie,iturn,nabs_total
16962       common  /info/ ie,iturn,nabs_total
16963 !
16964 !
16965       logical onesided,hit
16966       integer nprim,filel,mat,nev,j,nabs,nhit,np,icoll
16967 !MAY2005
16968 !      integer lhit(npart),part_abs(npart)
16969       integer lhit(npart),part_abs(npart),name(npart)
16970 !MAY2005
16971       double precision p0,xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax   &
16972      &,length,zlm,x,x00,xp,z,z00,zp,p,sp,dpop,s,enom,x_in(npart),       &
16973      &xp_in(npart),y_in(npart),yp_in(npart),p_in(npart),s_in(npart),    &
16974      &indiv(npart),lint(npart),x_out(max_npart),xp_out(max_npart),      &
16975      &y_out(max_npart),yp_out(max_npart),p_out(max_npart),              &
16976      &s_out(max_npart),keeps,fracab,mybetax,mybetaz,mymux,mymuz,sigx,   &
16977      &sigz,norma,xpmu,atdi,drift_length,mirror,tiltangle,impact(npart)
16978 !
16979       double precision c_length    !length in m
16980       double precision c_rotation  !rotation angle vs vertical in radian
16981       double precision c_aperture  !aperture in m
16982       double precision c_offset    !offset in m
16983       double precision c_tilt(2)   !tilt in radian
16984       character*6      c_material  !material
16985 !
16986 !
16987 !
16988       character*(nc) filen,tit
16989 !
16990       real   rndm4,xlow,xhigh,xplow,xphigh,dx,dxp
16991 !
16992       common /cmom/xmin,xmax,xpmin,xpmax,zmin,zmax,zpmin,zpmax,length,  &
16993      &nev
16994       common /materia/mat
16995       common /phase/x,xp,z,zp,dpop
16996       common /nommom/p0
16997       common /cjaw1/zlm
16998       common /other/mybetax,mybetaz,mymux,mymuz,atdi
16999       common /icoll/  icoll
17000 !
17001       data   dx,dxp/.5d-4,20.d-4/
17002 !
17003 !
17004 !
17005 !GRD
17006 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
17007 !GRD
17008 !APRIL2005
17009       logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside,     &
17010      &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial,        &
17011      &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
17012 !     &systilt_antisymm,dowritetracks,cern
17013 !APRIL2005
17014 !
17015 !      integer nloop,rnd_seed,ibeam,jobnumber,sigsecut2
17016 !JUNE2005
17017 !      integer nloop,rnd_seed,ibeam,jobnumber
17018 !SEPT2005 for slicing process
17019 !      integer nloop,rnd_seed,ibeam,jobnumber,do_thisdis
17020       integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber,         &
17021      &do_thisdis,n_slices,pencil_distr
17022 !JUNE2005
17023 !
17024 !UPGRADE JANUARY 2005
17025 !APRIL2005
17026 !      double precision myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
17027 !     &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,         &
17028       double precision myenom,mynex,mdex,myney,mdey,                    &
17029      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
17030      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
17031 !
17032      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
17033      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
17034 !
17035      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
17036 !SEPT2005 add these lines for the slicing procedure
17037      &smin_slices,smax_slices,recenter1,recenter2,                      &
17038      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
17039      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
17040 !SEPT2005,OCT2006 added offset
17041      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
17042      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
17043      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
17044      &c_sysoffset_sec,c_rmserror_gap,nr,ndr,                            &
17045 !     &driftsx,driftsy,pencil_offset,sigsecut3
17046 !JUNE2005
17047 !     &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
17048      &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,            &
17049      &sigsecut3,sigsecut2,enerror,bunchlength
17050 !JUNE2005
17051 !APRIL2005
17052 !
17053       character*24 name_sel
17054       character*80 coll_db
17055       character*16 castordir
17056 !JUNE2005
17057       character*80 filename_dis
17058 !JUNE2005
17059 !
17060 !UPGRADE JANUARY 2005
17061 !APRIL2005
17062 !JUNE2005
17063 !SEPT2005
17064 !      common /grd/ myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec,     &
17065 !     &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,         &
17066 !     &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,nr,     &
17067 !     &ndr,driftsx,driftsy,pencil_offset,sigsecut3,coll_db,name_sel,     &
17068 !     &castordir,abs_db,nloop,rnd_seed,ibeam,jobnumber,sigsecut2,do_coll,&
17069 !     &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
17070 !     &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
17071 !     &dowritetracks,cern
17072       common /grd/ myenom,mynex,mdex,myney,mdey,                        &
17073      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
17074      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
17075 !
17076      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
17077      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
17078 !
17079      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
17080 !
17081      &smin_slices,smax_slices,recenter1,recenter2,                      &
17082      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
17083      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
17084 !
17085      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
17086      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
17087      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
17088      &c_sysoffset_sec,c_rmserror_gap,nr,                                &
17089 !
17090      &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,        &
17091      &sigsecut3,sigsecut2,enerror,                                      &
17092      &bunchlength,coll_db,name_sel,                                     &
17093      &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed,          &
17094      &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr,                 &
17095      &do_coll,                                                          &
17096 !
17097      &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
17098      &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
17099      &dowritetracks,cern,do_nsig,do_mingap
17100 !SEPT2005
17101 !JUNE2005
17102 !APRIL2005
17103 !
17104 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17105 !
17106 !
17107       double precision x_flk,xp_flk,y_flk,yp_flk
17108 !JUNE2005
17109       double precision n_aperture  !aperture in m for the vertical plane
17110 !JUNE2005
17111 !DEBUG
17112       integer event
17113 !DEBUG
17114       save
17115 !=======================================================================
17116 ! Be=1 Al=2 Cu=3 W=4 Pb=5
17117 !
17118 ! LHC uses:    Al, 0.2 m
17119 !              Cu, 1.0 m
17120 !
17121 !      write(*,*) 'enter collimateRHIC routine'
17122       if (c_material.eq.'BE') then
17123          mat = 1
17124       elseif (c_material.eq.'AL') then
17125          mat = 2
17126       elseif (c_material.eq.'CU') then
17127          mat = 3
17128       elseif (c_material.eq.'W') then
17129          mat = 4
17130       elseif (c_material.eq.'PB') then
17131          mat = 5
17132       elseif (c_material.eq.'C') then
17133          mat = 6
17134       elseif (c_material.eq.'C2') then
17135          mat = 7
17136       else
17137          write(*,*) 'ERR>  Material not found. STOP (TW)', c_material
17138 !        STOP
17139       endif
17140 !
17141         length  = c_length
17142         nev = np
17143         p0  = enom
17144 !
17145 !++  Initialize scattering processes
17146 !
17147       call scatin(p0)
17148  
17149 ! EVENT LOOP,  initial distribution is here a flat distribution with
17150 ! xmin=x-, xmax=x+, etc. from the input file
17151 !
17152       nhit    = 0
17153       fracab  = 0.
17154       mirror  = 1.
17155 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
17156       do j = 1, nev
17157 !
17158         impact(j) = -1.
17159         lint(j)   = -1.
17160         indiv(j)  = -1.
17161 !
17162         x   = x_in(j)
17163         xp  = xp_in(j)
17164         z   = y_in(j)
17165         zp  = yp_in(j)
17166         p   = p_in(j)
17167 !        sp  = s_in(J)
17168         sp   = 0.
17169         dpop = (p - p0)/p0
17170 !
17171 !++  Transform particle coordinates to get into collimator coordinate
17172 !++  system
17173 !
17174 !++  First check whether particle was lost before
17175 !
17176 !        if (x.lt.99.0*1e-3 .and. z.lt.99.0*1e-3) then
17177         if (x.lt.99.0*1d-3 .and. z.lt.99.0*1d-3) then
17178 !
17179 !++  First do rotation into collimator frame
17180 !
17181 !JUNE2005
17182 !JUNE2005 CHANGE TO MAKE THE RHIC TREATMENT EASIER...
17183 !JUNE2005
17184 !+if crlibm
17185 !          x  = x_in(j)*cos_rn(c_rotation) +sin_rn(c_rotation)*y_in(j)
17186 !+ei
17187 !+if .not.crlibm
17188 !          x  = x_in(j)*cos(c_rotation) +sin(c_rotation)*y_in(j)
17189 !+ei
17190 !+if crlibm
17191 !          z  = y_in(j)*cos_rn(c_rotation) -sin_rn(c_rotation)*x_in(j)
17192 !+ei
17193 !+if .not.crlibm
17194 !          z  = y_in(j)*cos(c_rotation) -sin(c_rotation)*x_in(j)
17195 !+ei
17196 !+if crlibm
17197 !          xp = xp_in(j)*cos_rn(c_rotation)+sin_rn(c_rotation)*yp_in(j)
17198 !+ei
17199 !+if .not.crlibm
17200 !          xp = xp_in(j)*cos(c_rotation)+sin(c_rotation)*yp_in(j)
17201 !+ei
17202 !+if crlibm
17203 !          zp = yp_in(j)*cos_rn(c_rotation)-sin_rn(c_rotation)*xp_in(j)
17204 !+ei
17205 !+if .not.crlibm
17206 !          zp = yp_in(j)*cos(c_rotation)-sin(c_rotation)*xp_in(j)
17207 !+ei
17208           x  = -1d0*x_in(j)
17209           z  = -1d0*y_in(j)
17210           xp = -1d0*xp_in(j)
17211           zp = -1d0*yp_in(j)
17212 !JUNE2005
17213 !
17214 !++  For one-sided collimators consider only positive X. For negative
17215 !++  X jump to the next particle
17216 !
17217 !GRD          IF (ONESIDED .AND. X.LT.0) GOTO 777
17218 !JUNE2005          if (onesided .and. x.lt.0d0 .or. z.gt.0d0) goto 777
17219           if (onesided .and. (x.lt.0d0 .and. z.gt.0d0)) goto 777
17220 !
17221 !++  Now mirror at the horizontal axis for negative X offset
17222 !
17223 !GRD
17224 !GRD THIS WE HAVE TO COMMENT OUT IN CASE OF RHIC BECAUSE THERE ARE
17225 !GRD ONLY ONE-SIDED COLLIMATORS
17226 !GRD
17227 !          IF (X.LT.0) THEN
17228 !            MIRROR = -1.
17229 !            tiltangle = -1.*C_TILT(2)
17230 !          ELSE
17231 !            MIRROR = 1.
17232             tiltangle = c_tilt(1)
17233 !          ENDIF
17234 !          X  = MIRROR * X
17235 !          XP = MIRROR * XP
17236 !GRD
17237 !
17238 !++  Shift with opening and offset
17239 !
17240           x  = x - c_aperture/2 - mirror*c_offset
17241 !GRD
17242 !GRD SPECIAL FEATURE TO TAKE INTO ACCOUNT THE PARTICULAR SHAPE OF RHIC PRIMARY C
17243 !GRD
17244 !JUNE2005  HERE WE ADD THE ABILITY TO HAVE 2 DIFFERENT OPENINGS FOR THE TWO PLAN
17245 !JUNE2005  OF THE PRIMARY COLLIMATOR OF RHIC
17246 !JUNE2005
17247 !          z  = z + c_aperture/2 + mirror*c_offset
17248           z  = z + n_aperture/2 + mirror*c_offset
17249 !JUNE2005
17250 !          if(iturn.eq.1)                                                &
17251 !     &write(*,*) 'check ',x,xp,z,zp,c_aperture,n_aperture
17252 !JUNE2005
17253 !
17254 !++  Include collimator tilt
17255 !
17256           if (tiltangle.gt.0.) then
17257             xp = xp - tiltangle
17258           elseif (tiltangle.lt.0.) then
17259             x  = x + sin(tiltangle) * c_length
17260             xp = xp - tiltangle
17261           endif
17262 !
17263 !++  For selected collimator, first turn reset particle distribution
17264 !++  to simple pencil beam
17265 !
17266             nprim = 3
17267             if ( (icoll.eq.ipencil                                      &
17268      &.and. iturn.eq.1) .or.                                            &
17269      &(iturn.eq.1 .and. ipencil.eq.999 .and.                            &
17270      &icoll.le.nprim .and.                                              &
17271      &(j.ge.(icoll-1)*nev/nprim) .and.                                  &
17272      &(j.le.(icoll)*nev/nprim)                                          &
17273      &)  ) then
17274               x    = pencil_dx(icoll)
17275               xp   = 0.
17276               z    = 0.
17277               zp   = 0.
17278               dpop = 0.
17279               if(rndm4().lt.0.5) mirror = -abs(mirror)
17280               if(rndm4().ge.0.5) mirror = abs(mirror)
17281             endif
17282 !
17283 !++  particle passing above the jaw are discarded => take new event
17284 !++  entering by the face, shorten the length (zlm) and keep track of
17285 !++  entrance longitudinal coordinate (keeps) for histograms
17286 !
17287 !++  The definition is that the collimator jaw is at x>=0.
17288 !
17289 !++  1) Check whether particle hits the collimator
17290 !
17291           hit     =  .false.
17292           s       =  0.
17293           keeps   =  0.
17294           zlm     =  -1.0d0 * length
17295 !
17296 !GRD
17297 !JUNE2005          if (x.ge.0d0 .and. z.le.0d0) then
17298           if (x.ge.0d0 .and. z.le.0d0) then
17299              goto 10
17300 !
17301 !++  Particle hits collimator and we assume interaction length ZLM equal
17302 !++  to collimator length (what if it would leave collimator after
17303 !++  small length due to angle???)
17304 !
17305 !JUNE2005
17306 !            zlm = length
17307 !            impact(j) = max(x,(-1d0*z))
17308 !            if(impact(j).eq.x) then
17309 !               indiv(j) = xp
17310 !            else
17311 !               indiv(j) = zp
17312 !            endif
17313 !          endif
17314 !JUNE2005
17315 !GRD
17316 !JUNE2005          if(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.ge.0d0) then
17317           elseif(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0                    &
17318      &.and.zp.ge.0d0) then
17319              goto 20
17320 !GRD
17321 !JUNE2005          if(x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.ge.0d0) then
17322 !
17323 !++  Particle does not hit collimator. Interaction length ZLM is zero.
17324 !
17325 !JUNE2005            zlm = 0.
17326 !JUNE2005          endif
17327 !GRD
17328 !JUNE2005          if (x.lt.0d0.and.z.gt.0d0.and.xp.gt.0d0.and.zp.ge.0d0) then
17329 !JUNE2005
17330 !            zlm = 0.
17331 !          endif
17332 !JUNE2005
17333 !
17334 !JUNE2005
17335 !JUNE2005 THAT WAS PIECE OF CAKE; NOW COMES THE TRICKY PART...
17336 !JUNE2005
17337 !JUNE2005 THE IDEA WOULD BE TO FIRST LIST ALL THE IMPACT
17338 !JUNE2005 POSSIBILITIES, THEN SEND VIA GOTO TO THE CORRECT
17339 !JUNE2005 TREATMENT
17340 !JUNE2005
17341           elseif((x.lt.0d0).and.(z.le.0d0)) then
17342              goto 100
17343           elseif((x.ge.0d0).and.(z.gt.0d0)) then
17344              goto 200
17345           elseif((x.lt.0d0).and.(xp.gt.0d0)) then
17346              goto 300
17347           elseif((z.gt.0d0).and.(zp.lt.0d0)) then
17348              goto 400
17349           endif
17350 !GRD
17351  10         continue
17352             event = 10
17353             zlm = length
17354             impact(j) = max(x,(-1d0*z))
17355             if(impact(j).eq.x) then
17356                indiv(j) = xp
17357             else
17358                indiv(j) = zp
17359             endif
17360             goto 999
17361 !GRD
17362  20         continue
17363             event = 20
17364             zlm = 0.
17365             goto 999
17366 !GRD
17367  100        continue
17368             event = 100
17369             zlm = length
17370             impact(j) = -1d0*z
17371             indiv(j) = zp
17372             goto 999
17373 !GRD
17374  200        continue
17375             event = 200
17376             zlm = length
17377             impact(j) = x
17378             indiv(j) = xp
17379             goto 999
17380 !GRD
17381 !JUNE2005
17382 !JUNE2005 HERE ONE HAS FIRST TO CHECK IF THERE'S NOT A HIT IN THE
17383 !JUNE2005 OTHER PLANE AT THE SAME TIME
17384 !JUNE2005
17385  300        continue
17386             event = 300
17387             if(z.gt.0d0.and.zp.lt.0d0) goto 500
17388 !
17389 !++  Calculate s-coordinate of interaction point
17390 !
17391             s = (-1.0d0*x) / xp
17392             if (s.le.0d0) then
17393               write(*,*) 'S.LE.0 -> This should not happen (1)'
17394               stop
17395             endif
17396 !
17397             if (s .lt. length) then
17398               zlm = length - s
17399               impact(j) = 0.
17400               indiv(j) = xp
17401             else
17402               zlm = 0.
17403             endif
17404             goto 999
17405 !GRD
17406  400        continue
17407             event = 400
17408 !JUNE2005          if (x.lt.0d0.and.z.gt.0d0.and.xp.le.0d0.and.zp.lt.0d0) then
17409 !
17410 !++  Calculate s-coordinate of interaction point
17411 !
17412             s = (-1.0d0*z) / zp
17413             if (s.le.0) then
17414               write(*,*) 'S.LE.0 -> This should not happen (2)'
17415               stop
17416             endif
17417 !
17418             if (s .lt. length) then
17419               zlm = length - s
17420               impact(j) = 0.
17421               indiv(j) = zp
17422             else
17423               zlm = 0.
17424             endif
17425 !JUNE2005          endif
17426 !GRD
17427             goto 999
17428 !GRD
17429 !GRD
17430 !JUNE2005          if (x.lt.0d0.and.z.gt.0d0.and.xp.gt.0d0.and.zp.lt.0d0) then
17431  500        continue
17432             event = 500
17433 !
17434 !++  Calculate s-coordinate of interaction point
17435 !
17436             sx = (-1.0d0*x) / xp
17437             sz = (-1.0d0*z) / zp
17438 !
17439             if(sx.lt.sz) s=sx
17440             if(sx.ge.sz) s=sz
17441 !
17442             if (s.le.0d0) then
17443               write(*,*) 'S.LE.0 -> This should not happen (3)'
17444               stop
17445             endif
17446 !
17447             if (s .lt. length) then
17448               zlm = length - s
17449               impact(j) = 0.
17450               if(s.eq.sx) then
17451                 indiv(j) = xp
17452               else
17453                 indiv(j) = zp
17454               endif
17455             else
17456               zlm = 0.
17457             endif
17458 !
17459 !JUNE2005          endif
17460 !GRD
17461 !GRD
17462  999      continue
17463 !JUNE2005
17464 !          write(*,*) 'event ',event,x,xp,z,zp
17465 !          if(impact(j).lt.0d0) then
17466 !             if(impact(j).ne.-1d0)                                      &
17467 !     &write(*,*) 'argh! ',impact(j),x,xp,z,zp,s,event
17468 !          endif
17469 !          if(impact(j).ge.0d0) then
17470 !      write(*,*) 'impact! ',impact(j),x,xp,z,zp,s,event
17471 !          endif
17472 !JUNE2005
17473 !
17474 !++  First do the drift part
17475 !
17476           drift_length = length - zlm
17477           if (drift_length.gt.0.) then
17478             x  = x + xp* drift_length
17479             z  = z + zp * drift_length
17480             sp = sp + drift_length
17481           endif
17482 !
17483 !++  Now do the scattering part
17484 !
17485           if (zlm.gt.0.) then
17486             nhit = nhit + 1
17487 !            WRITE(*,*) J,X,XP,Z,ZP,SP,DPOP
17488 !DEBUG
17489 !            write(*,*) 'abs?',s,zlm
17490 !DEBUG
17491 !JUNE2005
17492 !JUNE2005 IN ORDER TO HAVE A PROPER TREATMENT IN THE CASE OF THE VERTICAL
17493 !JUNE2005 PLANE, CHANGE AGAIN THE FRAME FOR THE SCATTERING SUBROUTINES...
17494 !JUNE2005
17495             if(event.eq.100.or.event.eq.400) then
17496 !GRD first go back into normal frame...
17497                x = x + c_aperture/2 + mirror*c_offset
17498                z = z - n_aperture/2 - mirror*c_offset
17499                x = -1d0*x
17500                xp = -1d0*xp
17501                z = -1d0*z
17502                zp = -1d0*zp
17503 !GRD ...then do as for a vertical collimator
17504                x = z
17505                xp = zp
17506                z = -1d0*x
17507                zp = -1d0*x
17508                x  = x - n_aperture/2 - mirror*c_offset
17509                z  = z + c_aperture/2 + mirror*c_offset
17510             endif
17511 !JUNE2005
17512             call jaw(s, nabs)
17513 !DEBUG
17514 !            write(*,*) 'abs?',nabs
17515 !DEBUG
17516 !JUNE2005
17517 !JUNE2005 ...WITHOUT FORGETTING TO GO BACK TO THE "ORIGINAL" FRAME AFTER THE
17518 !JUNE2005 ROUTINES, SO AS TO AVOID RIDICULOUS VALUES FOR KICKS IN EITHER PLANE
17519             if(event.eq.100.or.event.eq.400) then
17520 !GRD first go back into normal frame...
17521                x = x + n_aperture/2 + mirror*c_offset
17522                z = z - c_aperture/2 - mirror*c_offset
17523                x = -1d0*z
17524                xp = -1d0*zp
17525                z = x
17526                zp = xp
17527 !GRD ...then go back to face the horizontal jaw at 180 degrees
17528                x = -1d0*x
17529                xp = -1d0*xp
17530                z = -1d0*z
17531                zp = -1d0*zp
17532                x  = x - c_aperture/2 - mirror*c_offset
17533                z  = z + n_aperture/2 + mirror*c_offset
17534             endif
17535 !JUNE2005
17536             lhit(j) = 10000*ie + iturn
17537 !
17538 !++  If particle is absorbed then set x and y to 99.99 mm
17539 !
17540             if (nabs.eq.1) then
17541 !APRIL2005
17542 !TO WRITE FLUKA INPUT CORRECTLY, WE HAVE TO GO BACK IN THE MACHINE FRAME
17543             if (tiltangle.gt.0.) then
17544               x  = x  + tiltangle*c_length
17545               xp = xp + tiltangle
17546             elseif (tiltangle.lt.0.) then
17547               x  = x + tiltangle*c_length
17548               xp = xp + tiltangle
17549 !
17550               x  = x - sin(tiltangle) * c_length
17551             endif
17552 !
17553 !++  Transform back to particle coordinates with opening and offset
17554 !
17555             x = x + c_aperture/2 + mirror*c_offset
17556 !GRD
17557 !JUNE2005  OF COURSE WE ADAPT ALSO THE PREVIOUS CHANGE WHEN SHIFTING BACK
17558 !JUNE2005  TO  THE ACCELERATOR FRAME...
17559 !            z = z - c_aperture/2 - mirror*c_offset
17560             z = z - n_aperture/2 - mirror*c_offset
17561 !JUNE2005
17562 !
17563 !++   Last do rotation into collimator frame
17564 !
17565                   x_flk  = -1d0*x
17566                   y_flk  = -1d0*z
17567                   xp_flk = -1d0*xp
17568                   yp_flk = -1d0*zp
17569 !NOW WE CAN WRITE THE COORDINATES OF THE LOST PARTICLES
17570               if(dowrite_impact) then
17571       write(48,'(i4,(2x,f5.3),(2x,f8.6),4(1x,e16.7),2x,i2,2x,i5)')      &
17572      &icoll,c_rotation,s+sp,                                            &
17573      &x_flk*1d3, xp_flk*1d3, y_flk*1d3, yp_flk*1d3,                     &
17574      &nabs,name(j)
17575               endif
17576 !APRIL2005
17577               fracab = fracab + 1
17578 !              x = 99.99*1e-3
17579 !              z = 99.99*1e-3
17580               x = 99.99*1.0d-3
17581               z = 99.99*1.0d-3
17582               part_abs(j) = 10000*ie + iturn
17583               lint(j) = zlm
17584             endif
17585           endif
17586 !
17587 !++  Do the rest drift, if particle left collimator early
17588 !
17589           if (nabs.ne.1 .and. zlm.gt.0.) then
17590             drift_length = (length-(s+sp))
17591 !            if (drift_length.gt.1.e-15) then
17592             if (drift_length.gt.1.0d-15) then
17593 !              WRITE(*,*) J, DRIFT_LENGTH
17594               x  = x + xp * drift_length
17595               z  = z + zp * drift_length
17596               sp = sp + drift_length
17597             endif
17598             lint(j) = zlm - drift_length
17599           endif
17600 !
17601 !++  Transform back to particle coordinates with opening and offset
17602 !
17603 !          if (x.lt.99.0*1e-3 .and. z.lt.99.0*1e-3) then
17604           if (x.lt.99.0*1d-3 .and. z.lt.99.0*1d-3) then
17605 !
17606 !++  Include collimator tilt
17607 !
17608             if (tiltangle.gt.0.) then
17609               x  = x  + tiltangle*c_length
17610               xp = xp + tiltangle
17611             elseif (tiltangle.lt.0.) then
17612               x  = x + tiltangle*c_length
17613               xp = xp + tiltangle
17614 !
17615               x  = x - sin(tiltangle) * c_length
17616             endif
17617 !
17618 !++  Transform back to particle coordinates with opening and offset
17619 !
17620             z00 = z
17621             x00 = x + mirror*c_offset
17622             x = x + c_aperture/2 + mirror*c_offset
17623 !GRD
17624 !JUNE2005  OF COURSE WE ADAPT ALSO THE PREVIOUS CHANGE WHEN SHIFTING BACK
17625 !JUNE2005  TO  THE ACCELERATOR FRAME...
17626 !            z = z - c_aperture/2 - mirror*c_offset
17627             z = z - n_aperture/2 - mirror*c_offset
17628 !JUNE2005
17629 !
17630 !++  Now mirror at the horizontal axis for negative X offset
17631 !
17632             x    = mirror * x
17633             xp   = mirror * xp
17634 !
17635 !++  Last do rotation into collimator frame
17636 !
17637 !JUNE2005
17638 !+if crlibm
17639 !            x_in(j)  = x  *cos_rn(-1.*c_rotation) +                     &
17640 !+ei
17641 !+if .not.crlibm
17642 !            x_in(j)  = x  *cos(-1.*c_rotation) +                        &
17643 !+ei
17644 !+if crlibm
17645 !     &z  *sin_rn(-1.*c_rotation)
17646 !+ei
17647 !+if .not.crlibm
17648 !     &z  *sin(-1.*c_rotation)
17649 !+ei
17650 !+if crlibm
17651 !            y_in(j)  = z  *cos_rn(-1.*c_rotation) -                     &
17652 !+ei
17653 !+if .not.crlibm
17654 !            y_in(j)  = z  *cos(-1.*c_rotation) -                        &
17655 !+ei
17656 !+if crlibm
17657 !     &x  *sin_rn(-1.*c_rotation)
17658 !+ei
17659 !+if .not.crlibm
17660 !     &x  *sin(-1.*c_rotation)
17661 !+ei
17662 !+if crlibm
17663 !            xp_in(j) = xp *cos_rn(-1.*c_rotation) +                     &
17664 !+ei
17665 !+if .not.crlibm
17666 !            xp_in(j) = xp *cos(-1.*c_rotation) +                        &
17667 !+ei
17668 !+if crlibm
17669 !     &zp *sin_rn(-1.*c_rotation)
17670 !+ei
17671 !+if .not.crlibm
17672 !     &zp *sin(-1.*c_rotation)
17673 !+ei
17674 !+if crlibm
17675 !            yp_in(j) = zp *cos_rn(-1.*c_rotation) -                     &
17676 !+ei
17677 !+if .not.crlibm
17678 !            yp_in(j) = zp *cos(-1.*c_rotation) -                        &
17679 !+ei
17680 !+if crlibm
17681 !     &xp *sin_rn(-1.*c_rotation)
17682 !+ei
17683 !+if .not.crlibm
17684 !     &xp *sin(-1.*c_rotation)
17685 !+ei
17686             x_in(j) = -1d0*x
17687             y_in(j) = -1d0*z
17688             xp_in(j) = -1d0*xp
17689             yp_in(j) = -1d0*zp
17690 !JUNE2005
17691 !
17692             if ( (icoll.eq.ipencil                                      &
17693      &.and. iturn.eq.1)   .or.                                          &
17694      &(iturn.eq.1 .and. ipencil.eq.999 .and.                            &
17695      &icoll.le.nprim .and.                                              &
17696      &(j.ge.(icoll-1)*nev/nprim) .and.                                  &
17697      &(j.le.(icoll)*nev/nprim)                                          &
17698      &)  ) then
17699 !
17700                x00  = mirror * x00
17701                x_in(j)  = x00  *cos(-1.*c_rotation) +                   &
17702      &z00  *sin(-1.*c_rotation)
17703                y_in(j)  = z00  *cos(-1.*c_rotation) -                   &
17704      &x00  *sin(-1.*c_rotation)
17705 !
17706                xp_in(j) = xp_in(j) + mirror*xp_pencil0
17707                yp_in(j) = yp_in(j) + mirror*yp_pencil0
17708                x_in(j) = x_in(j) + mirror*x_pencil(icoll)
17709                y_in(j) = y_in(j) + mirror*y_pencil(icoll)
17710             endif
17711 !
17712             p_in(j) = (1 + dpop) * p0
17713             s_in(j) = s_in(j) + sp
17714 !
17715           else
17716             x_in(j)  = x
17717             y_in(j)  = z
17718           endif
17719 !
17720 !++  End of check for particles not being lost before
17721 !
17722         endif
17723 !
17724 !        IF (X.GT.99.00) WRITE(*,*) 'After : ', X, X_IN(J)
17725 !
17726 !++  End of loop over all particles
17727 !
17728  777  end do
17729 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
17730 !
17731 !      WRITE(*,*) 'Number of particles:            ', Nev
17732 !      WRITE(*,*) 'Number of particle hits:        ', Nhit
17733 !      WRITE(*,*) 'Number of absorped particles:   ', fracab
17734 !      WRITE(*,*) 'Number of escaped particles:    ', Nhit-fracab
17735 !      WRITE(*,*) 'Fraction of absorped particles: ', 100.*fracab/Nhit
17736 !
17737       end
17738 !
17739 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
17740 !
17741       subroutine makedis(mynp, myalphax, myalphay, mybetax, mybetay,    &
17742      &myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,             &
17743      &myx, myxp, myy, myyp, myp, mys)
17744 !
17745 !  Generate distribution
17746 !
17747       implicit none
17748 !
17749       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
17750 !UPGRADE January 2005
17751 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
17752       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
17753      &maxn=20000,outlun=54)
17754 !
17755 !++ Vectors of coordinates
17756 !
17757       logical cut_input
17758       integer i,j,mynp,nloop
17759       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
17760      &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
17761      &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay,   &
17762      &xsigmax,ysigmay,myenom,nr,ndr
17763 !
17764 !
17765       real      rndm4
17766 !
17767 !
17768       character*80   dummy
17769 !
17770 !
17771       common /cut/ cut_input
17772 !
17773 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17774 !
17775       double precision pi
17776 !
17777       save
17778 !-----------------------------------------------------------------------
17779 !++  Generate particle distribution
17780 !
17781 !
17782 !++  Generate random distribution, assuming optical parameters at IP1
17783 !
17784 !
17785 !++  Calculate the gammas
17786 !
17787       pi=4d0*atan(1d0)
17788       mygammax = (1d0+myalphax**2)/mybetax
17789       mygammay = (1d0+myalphay**2)/mybetay
17790 !++TW 11/07 reset j, helps if subroutine is called twice
17791 ! was done during try to reset distribution, still needed
17792 ! will this subroutine ever called twice?
17793       j = 0
17794 !
17795 !
17796 !++  Number of points and generate distribution
17797 !
17798       write(*,*)
17799       write(*,*) 'Generation of particle distribution Version 1'
17800       write(*,*)
17801       write(*,*) 'This routine generates particles in phase space'
17802       write(*,*) 'X/XP and Y/YP ellipses, as defined in the input'
17803       write(*,*) 'parameters. Distribution is flat in the band.'
17804       write(*,*) 'X and Y are fully uncorrelated.'
17805       write(*,*)
17806 !
17807       write(outlun,*)
17808       write(outlun,*) 'Generation of particle distribution Version 1'
17809       write(outlun,*)
17810       write(outlun,*) 'This routine generates particles in phase space'
17811       write(outlun,*) 'X/XP and Y/YP ellipses, as defined in the input'
17812       write(outlun,*) 'parameters. Distribution is flat in the band.'
17813       write(outlun,*) 'X and Y are fully uncorrelated.'
17814       write(outlun,*)
17815       write(outlun,*) 'INFO>  Number of particles   = ', mynp
17816       write(outlun,*) 'INFO>  Av number of x sigmas = ', mynex
17817       write(outlun,*) 'INFO>  +- spread in x sigmas = ', mdex
17818       write(outlun,*) 'I0NFO>  Av number of y sigmas = ', myney
17819       write(outlun,*) 'INFO>  +- spread in y sigmas = ', mdey
17820       write(outlun,*) 'INFO>  Nominal beam energy   = ', myenom
17821       write(outlun,*) 'INFO>  Sigma_x0 = ', sqrt(mybetax*myemitx0)
17822       write(outlun,*) 'INFO>  Sigma_y0 = ', sqrt(mybetay*myemity0)
17823       write(outlun,*) 'INFO>  Beta x   = ', mybetax
17824       write(outlun,*) 'INFO>  Beta y   = ', mybetay
17825       write(outlun,*) 'INFO>  Alpha x  = ', myalphax
17826       write(outlun,*) 'INFO>  Alpha y  = ', myalphay
17827       write(outlun,*) 'INFO>  DISP x  = '
17828       write(outlun,*) 'INFO>  DISP y  = '
17829 !
17830       do while (j.lt.mynp)
17831 !
17832         j = j + 1
17833         myemitx = myemitx0*(mynex + (2d0*dble(rndm4()-0.5)*mdex) )**2
17834         xsigmax = sqrt(mybetax*myemitx)
17835         myx(j)   = xsigmax * sin(2d0*pi*rndm4())
17836         if (rndm4().gt.0.5) then
17837           myxp(j)  = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-        &
17838      &myalphax*myx(j)/mybetax
17839         else
17840           myxp(j)  = -1*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-     &
17841      &myalphax*myx(j)/mybetax
17842         endif
17843 !
17844         myemity = myemity0*(myney + (2d0*dble(rndm4()-0.5)*mdey) )**2
17845         ysigmay = sqrt(mybetay*myemity)
17846         myy(j)   = ysigmay * sin(2d0*pi*rndm4())
17847         if (rndm4().gt.0.5) then
17848           myyp(j)  = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-        &
17849      &myalphay*myy(j)/mybetay
17850         else
17851           myyp(j)  = -1*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-     &
17852      &myalphay*myy(j)/mybetay
17853         endif
17854 !
17855 !APRIL2005 TEST FOR FATS FLAG
17856         myp(j)   = myenom
17857 !        if(j.eq.1) then
17858 !          myp(j)   = myenom*(1-0.01)
17859 !!       do j=2,mynp
17860 !        else
17861 !          myp(j) = myp(1) + (j-1)*2d0*0.01*myenom/(mynp-1)
17862 !        endif
17863 !APRIL2005 END OF TEST SECTION
17864         mys(j)   = 0d0
17865 !
17866 !++  Dangerous stuff, just for the moment
17867 !
17868         if (cut_input) then
17869           if ( (.not. (myy(j).lt.-.008d-3 .and. myyp(j).lt.0.1d-3 .and. &
17870      &myyp(j).gt.0d0) ) .and.                                           &
17871      &(.not. (myy(j).gt..008d-3 .and. myyp(j).gt.-0.1d-3 .and.          &
17872      &myyp(j).lt.0d0) ) ) then
17873             j = j - 1
17874           endif
17875         endif
17876 !
17877       end do
17878 !
17879       return
17880       end
17881 !
17882 !========================================================================
17883 !
17884 ! SR, 08-05-2005: Add the finite beam size in the other dimension
17885       subroutine makedis_st(mynp, myalphax, myalphay, mybetax, mybetay, &
17886      &     myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,        &
17887      &     myx, myxp, myy, myyp, myp, mys)
17888  
17889 !     Uses the old routine 'MAKEDIS' for the halo plane and adds the
17890 !     transverse beam size in the other plane (matched distrubutions
17891 !     are generated starting from thetwiss functions).
17892 !     If 'mynex' and 'myney' are BOTH set to zero, nominal bunches
17893 !     centred in the aperture centre are generated. (SR, 08-05-2005)
17894 !
17895       implicit none
17896 !
17897       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
17898 !UPGRADE January 2005
17899 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
17900       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
17901      &maxn=20000,outlun=54)
17902 !
17903 !++ Vectors of coordinates
17904 !
17905       logical cut_input
17906       integer i,j,mynp,nloop
17907       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
17908      &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
17909      &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay,   &
17910      &xsigmax,ysigmay,myenom,nr,ndr
17911 !
17912 !
17913       real      rndm4
17914 !
17915 !
17916       character*80   dummy
17917 !
17918 !
17919       common /cut/ cut_input
17920 !
17921 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
17922 !
17923       double precision pi
17924 !
17925       double precision iix, iiy, phix, phiy
17926 !
17927       save
17928 !
17929 !-----------------------------------------------------------------------
17930 !++  Generate particle distribution
17931 !
17932 !
17933 !++  Generate random distribution, assuming optical parameters at IP1
17934 !
17935 !++  Calculate the gammas
17936 !
17937       write(*,*) '  New routine to add the finite beam size in the'
17938       write(*,*) '  other dimension (SR, 08-06-2005).'
17939  
17940       pi=4d0*atan(1d0)
17941 !
17942       mygammax = (1d0+myalphax**2)/mybetax
17943       mygammay = (1d0+myalphay**2)/mybetay
17944 !
17945       do j=1, mynp
17946          if ((mynex.gt.0d0).and.(myney.eq.0d0)) then
17947             myemitx = myemitx0*(mynex+(2d0*dble(rndm4()-0.5)*mdex))**2
17948             xsigmax = sqrt(mybetax*myemitx)
17949             myx(j)   = xsigmax * sin(2d0*pi*rndm4())
17950             if (rndm4().gt.0.5) then
17951               myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-     &
17952      &              myalphax*myx(j)/mybetax
17953             else
17954               myxp(j) = -1d0*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-&
17955      &              myalphax*myx(j)/mybetax
17956             endif
17957 !
17958             phiy = 2*pi*rndm4()
17959 !
17960             iiy = -1d0*myemity0 * log( rndm4() )
17961 !
17962             myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
17963             myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) +           &
17964      &           myalphay * cos(phiy))
17965          elseif ( mynex.eq.0.and.myney.gt.0 ) then
17966             myemity = myemity0*(myney+(2d0*dble(rndm4()-0.5)*mdey))**2
17967             ysigmay = sqrt(mybetay*myemity)
17968             myy(j)   = ysigmay * sin(2d0*pi*rndm4())
17969             if (rndm4().gt.0.5) then
17970               myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-     &
17971      &              myalphay*myy(j)/mybetay
17972             else
17973               myyp(j) = -1d0*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-&
17974      &              myalphay*myy(j)/mybetay
17975             endif
17976 !
17977             phix = 2*pi*rndm4()
17978             iix = - myemitx0 * log( rndm4() )
17979 !
17980             myx(j) = sqrt(2*iix*mybetax) * cos(phix)
17981             myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) +           &
17982      &           myalphax * cos(phix))
17983          elseif ( mynex.eq.0.and.myney.eq.0 ) then
17984             phix = 2*pi*rndm4()
17985             iix = - myemitx0 * log( rndm4() )
17986 !
17987             myx(j) = sqrt(2*iix*mybetax) * cos(phix)
17988             myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) +           &
17989      &           myalphax * cos(phix))
17990             phiy = 2*pi*rndm4()
17991             iiy = - myemity0 * log( rndm4() )
17992 !
17993             myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
17994             myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) +           &
17995      &           myalphay * cos(phiy))
17996          else
17997             write(*,*) "Error - beam parameters not correctly set!"
17998          endif
17999 !
18000          myp(j)   = myenom
18001          mys(j)   = 0d0
18002 !
18003       end do
18004 !
18005       return
18006       end
18007 !
18008 !========================================================================
18009 !
18010 ! SR, 09-05-2005: Add the energy spread and the finite bunch length.
18011 !                 Gaussian distributions assumed
18012       subroutine makedis_de(mynp, myalphax, myalphay, mybetax, mybetay, &
18013      &     myemitx0, myemity0, myenom, mynex, mdex, myney, mdey,        &
18014      &     myx, myxp, myy, myyp, myp, mys,                              &
18015      &     enerror,bunchlength)
18016  
18017 !     Uses the old routine 'MAKEDIS' for the halo plane and adds the
18018 !     transverse beam size in the other plane (matched distrubutions
18019 !     are generated starting from thetwiss functions).
18020 !     If 'mynex' and 'myney' are BOTH set to zero, nominal bunches
18021 !     centred in the aperture centre are generated. (SR, 08-05-2005)
18022       implicit none
18023 !
18024       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18025 !UPGRADE January 2005
18026 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18027       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
18028      &maxn=20000,outlun=54)
18029 !
18030 !++ Vectors of coordinates
18031 !
18032       logical cut_input
18033       integer i,j,mynp,nloop
18034       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
18035      &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18036      &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay,   &
18037      &xsigmax,ysigmay,myenom,nr,ndr
18038 !
18039 !
18040       real      rndm4
18041 !
18042 !
18043       character*80   dummy
18044 !
18045 !
18046       common /cut/ cut_input
18047 !
18048 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18049 !
18050       double precision pi
18051 !
18052       double precision ran_gauss
18053       double precision iix, iiy, phix, phiy
18054       double precision enerror, bunchlength
18055       double precision en_error, bunch_length
18056 !
18057       double precision long_cut
18058       double precision a_st, b_st
18059 !
18060       save
18061 !-----------------------------------------------------------------------
18062 !++  Generate particle distribution
18063 !
18064 !
18065 !++  Generate random distribution, assuming optical parameters at IP1
18066 !
18067 !++  Calculate the gammas
18068       pi=4d0*atan(1d0)
18069 !
18070       mygammax = (1d0+myalphax**2)/mybetax
18071       mygammay = (1d0+myalphay**2)/mybetay
18072  
18073 !     Assign bunch length and dp/p depending on the energy
18074 !     Check if the units in metres are correct!
18075 !GRD      if ( myenom.eq.7e6 ) then
18076 !GRD         en_error     = 1.129e-4
18077 !GRD         bunch_length = 7.55e-2
18078 !GRD      elseif ( myenom.eq.4.5e5 ) then
18079 !GRD         en_error     = 3.06e-4
18080 !GRD         bunch_length = 11.24e-2
18081 !GRD      else
18082       en_error = enerror
18083       bunch_length = bunchlength
18084 !GRD         write(*,*)"Warning-Energy different from LHC inj or top!"
18085 !GRD         write(*,*)"     => 7TeV values of dp/p and bunch length used!"
18086 !GRD      endif
18087 !GRD
18088       write (*,*) "Generation of bunch with dp/p and length:"
18089       write (*,*) "  RMS bunch length  = ", bunch_length
18090       write (*,*) "  RMS energy spread = ", en_error
18091       do j=1, mynp
18092          if ((mynex.gt.0d0).and.(myney.eq.0d0)) then
18093             myemitx = myemitx0*(mynex+(2d0*dble(rndm4()-0.5)*mdex))**2
18094             xsigmax = sqrt(mybetax*myemitx)
18095             myx(j)   = xsigmax * sin(2d0*pi*rndm4())
18096             if (rndm4().gt.0.5) then
18097               myxp(j) = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-     &
18098      &              myalphax*myx(j)/mybetax
18099             else
18100               myxp(j) = -1d0*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-&
18101      &              myalphax*myx(j)/mybetax
18102             endif
18103 !
18104             phiy = 2*pi*rndm4()
18105 !
18106             iiy = -1d0*myemity0 * log( rndm4() )
18107 !
18108             myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
18109             myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) +           &
18110      &           myalphay * cos(phiy))
18111          elseif ( mynex.eq.0.and.myney.gt.0 ) then
18112             myemity = myemity0*(myney+(2d0*dble(rndm4()-0.5)*mdey))**2
18113             ysigmay = sqrt(mybetay*myemity)
18114             myy(j)   = ysigmay * sin(2d0*pi*rndm4())
18115             if (rndm4().gt.0.5) then
18116               myyp(j) = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-     &
18117      &              myalphay*myy(j)/mybetay
18118             else
18119               myyp(j) = -1d0*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-&
18120      &              myalphay*myy(j)/mybetay
18121             endif
18122 !
18123             phix = 2*pi*rndm4()
18124             iix = - myemitx0 * log( rndm4() )
18125 !
18126             myx(j) = sqrt(2*iix*mybetax) * cos(phix)
18127             myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) +           &
18128      &           myalphax * cos(phix))
18129          elseif ( mynex.eq.0.and.myney.eq.0 ) then
18130             phix = 2*pi*rndm4()
18131             iix = - myemitx0 * log( rndm4() )
18132 !
18133             myx(j) = sqrt(2*iix*mybetax) * cos(phix)
18134             myxp(j) = -1d0*sqrt(2*iix/mybetax) * (sin(phix) +           &
18135      &           myalphax * cos(phix))
18136             phiy = 2*pi*rndm4()
18137             iiy = - myemity0 * log( rndm4() )
18138 !
18139             myy(j) = sqrt(2*iiy*mybetay) * cos(phiy)
18140             myyp(j) = -1d0*sqrt(2*iiy/mybetay) * (sin(phiy) +           &
18141      &           myalphay * cos(phiy))
18142          else
18143             write(*,*) "Error - beam parameters not correctly set!"
18144          endif
18145 !
18146       end do
18147 ! SR, 11-08-2005 For longitudinal phase-space, add a cut at 2 sigma
18148 !++   1st: generate mynpnumbers within the chose cut
18149       long_cut = 2
18150       j = 1
18151       do while (j.le.mynp)
18152          a_st = ran_gauss(5d0)
18153          b_st = ran_gauss(5d0)
18154          do while ((a_st*a_st+b_st*b_st).gt.long_cut*long_cut)
18155             a_st = ran_gauss(5d0)
18156             b_st = ran_gauss(5d0)
18157          enddo
18158          mys(j) = a_st
18159          myp(j) = b_st
18160          j = j + 1
18161       enddo
18162 !++   2nd: give the correct values
18163       do j=1,mynp
18164          myp(j) = myenom * (1d0 + myp(j) * en_error)
18165          mys(j) = bunch_length * mys(j)
18166       enddo
18167 !
18168       return
18169       end
18170 !
18171 !========================================================================
18172 !
18173       subroutine readdis(filename_dis, mynp,
18174      &     myx, myxp, myy, myyp, myp, mys)
18175 !
18176 !     SR, 09-08-2005
18177 !     Format for the input file:
18178 !               x, y   -> [ m ]
18179 !               xp, yp -> [ rad ]
18180 !               s      -> [ mm ]
18181 !               DE     -> [ MeV ]
18182 !
18183       implicit none
18184  
18185       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18186 !UPGRADE January 2005
18187 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18188       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
18189      &maxn=20000,outlun=54)
18190 !
18191 !++ Vectors of coordinates
18192 !
18193       logical cut_input
18194       integer i,j,mynp,nloop
18195       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
18196      &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18197      &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay,   &
18198      &xsigmax,ysigmay,myenom,nr,ndr
18199 !
18200 !
18201       real      rndm4
18202 !
18203 !
18204       character*80   dummy
18205 !
18206 !
18207       common /cut/ cut_input
18208 !
18209 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18210 !
18211  
18212       character*80   filename_dis
18213  
18214       save
18215  
18216       write(*,*) "Reading input bunch from ", filename_dis
18217  
18218       open(unit=111, file=filename_dis)
18219  
18220       do j=1,mynp
18221          read(111,*,end=10) myx(j), myxp(j), myy(j), myyp(j),
18222      &        mys(j), myp(j)
18223       enddo
18224  
18225  10   mynp = j - 1
18226       write(*,*) "Number of particles in the bunch = ",mynp
18227  
18228       close(111)
18229  
18230       return
18231       end
18232 !
18233 !========================================================================
18234 !
18235       subroutine makedis_radial(mynp, myalphax, myalphay, mybetax,      &
18236      &mybetay, myemitx0, myemity0, myenom, nr, ndr,myx, myxp, myy,      &
18237      &myyp, myp, mys)
18238 !
18239       implicit none
18240 !
18241       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
18242 !UPGRADE January 2005
18243 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
18244       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
18245      &maxn=20000,outlun=54)
18246 !
18247 !++ Vectors of coordinates
18248 !
18249       logical cut_input
18250       integer i,j,mynp,nloop
18251       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
18252      &myp(maxn),mys(maxn),myalphax,mybetax,myemitx0,myemitx,mynex,mdex, &
18253      &mygammax,myalphay,mybetay,myemity0,myemity,myney,mdey,mygammay,   &
18254      &xsigmax,ysigmay,myenom,nr,ndr
18255 !
18256 !
18257       real      rndm4
18258 !
18259 !
18260       character*80   dummy
18261 !
18262 !
18263       common /cut/ cut_input
18264 !
18265 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
18266 !
18267       double precision pi
18268 !
18269       save
18270 !-----------------------------------------------------------------------
18271 !++  Generate particle distribution
18272 !
18273 !
18274 !++  Generate random distribution, assuming optical parameters at IP1
18275 !
18276 !++  Calculate the gammas
18277 !
18278       pi=4d0*atan(1d0)
18279       mygammax = (1d0+myalphax**2)/mybetax
18280       mygammay = (1d0+myalphay**2)/mybetay
18281 !
18282 !++  Number of points and generate distribution
18283 !
18284       mynex = nr/sqrt(2d0)
18285       mdex = ndr/sqrt(2d0)
18286       myney = nr/sqrt(2d0)
18287       mdey = ndr/sqrt(2d0)
18288 !
18289       write(*,*)
18290       write(*,*) 'Generation of particle distribution Version 2'
18291       write(*,*)
18292       write(*,*) 'This routine generates particles in that are fully'
18293       write(*,*) 'correlated between X and Y.'
18294       write(*,*)
18295 !
18296       write(outlun,*)
18297       write(outlun,*) 'Generation of particle distribution Version 2'
18298       write(outlun,*)
18299       write(outlun,*)                                                   &
18300      &'This routine generates particles in that are fully'
18301       write(outlun,*) 'correlated between X and Y.'
18302       write(outlun,*)
18303       write(outlun,*)
18304       write(outlun,*) 'INFO>  Number of particles   = ', mynp
18305       write(outlun,*) 'INFO>  Av number of x sigmas = ', mynex
18306       write(outlun,*) 'INFO>  +- spread in x sigmas = ', mdex
18307       write(outlun,*) 'INFO>  Av number of y sigmas = ', myney
18308       write(outlun,*) 'INFO>  +- spread in y sigmas = ', mdey
18309       write(outlun,*) 'INFO>  Nominal beam energy   = ', myenom
18310       write(outlun,*) 'INFO>  Sigma_x0 = ', sqrt(mybetax*myemitx0)
18311       write(outlun,*) 'INFO>  Sigma_y0 = ', sqrt(mybetay*myemity0)
18312       write(outlun,*)
18313 !
18314       do while (j.lt.mynp)
18315 !
18316         j = j + 1
18317         myemitx = myemitx0*(mynex + (2d0*dble(rndm4()-0.5)*mdex) )**2
18318         xsigmax = sqrt(mybetax*myemitx)
18319         myx(j)   = xsigmax * sin(2d0*pi*rndm4())
18320         if (rndm4().gt.0.5) then
18321           myxp(j)  = sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-        &
18322      &myalphax*myx(j)/mybetax
18323         else
18324           myxp(j)  = -1*sqrt(myemitx/mybetax-myx(j)**2/mybetax**2)-     &
18325      &myalphax*myx(j)/mybetax
18326         endif
18327 !
18328         myemity = myemity0*(myney + (2d0*dble(rndm4()-0.5)*mdey) )**2
18329         ysigmay = sqrt(mybetay*myemity)
18330         myy(j)   = ysigmay * sin(2d0*pi*rndm4())
18331         if (rndm4().gt.0.5) then
18332           myyp(j)  = sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-        &
18333      &myalphay*myy(j)/mybetay
18334         else
18335           myyp(j)  = -1*sqrt(myemity/mybetay-myy(j)**2/mybetay**2)-     &
18336      &myalphay*myy(j)/mybetay
18337         endif
18338 !
18339 !APRIL2005
18340         myp(j)   = myenom
18341 !        if(j.eq.1) then
18342 !          myp(j)   = myenom*(1-0.05)
18343 !!       do j=2,mynp
18344 !        else
18345 !          myp(j) = myp(1) + (j-1)*2d0*0.05*myenom/(mynp-1)
18346 !        endif
18347 !APRIL2005
18348         mys(j)   = 0d0
18349 !
18350 !++  Dangerous stuff, just for the moment
18351 !
18352 !        IF ( (.NOT. (Y(j).LT.-.008e-3 .AND. YP(j).LT.0.1e-3 .AND.
18353 !     1               YP(j).GT.0.0) ) .AND.
18354 !     2       (.NOT. (Y(j).GT..008e-3 .AND. YP(j).GT.-0.1e-3 .AND.
18355 !     3               YP(j).LT.0.0) ) ) THEN
18356 !          J = J - 1
18357 !        ENDIF
18358 !
18359       end do
18360 !
18361       return
18362       end
18363 !
18364 !-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----GRD-----
18365 !
18366       function ichoix(ma)
18367       implicit none
18368       integer nrmat,nmat,mat,irmat,mcurr
18369 !     parameter(nmat=12,nrmat=5)
18370       parameter(nmat=12,nrmat=7)
18371       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18372      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18373      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18374      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18375       parameter(fnavo=6.02e23)
18376       real cgen
18377       character * 4 mname(nmat)
18378       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18379       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18380       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18381       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18382       common/scatu2/xintl(nmat),radl(nmat),mname
18383       common/scatpp/pptot,ppel,ppsd
18384       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18385       common/phase/x,xp,z,zp,dpop
18386       common/nommom/p0
18387       common/cjaw1/zlm
18388       common/cmcs1/zlm1
18389       common/materia/mat
18390       common/sindif/xpsd,zpsd,psd
18391       common/cdpodx/dpodx
18392       integer ma,i,ichoix
18393       double precision aran
18394       real rndm4
18395       aran=dble(rndm4())
18396       i=1
18397   10  if ( aran.gt.cprob(i,ma) ) then
18398           i=i+1
18399           goto 10
18400       endif
18401       ichoix=i
18402       return
18403       end
18404 !---------------------------------------------------------------
18405 !
18406       function gettran(inter,xmat,p)
18407 !
18408 !++  This function determines: GETTRAN - rms transverse momentum transfer
18409 !
18410 !++  Note: For single-diffractive scattering the vector p of momentum
18411 !++        is modified (energy loss is applied)
18412 !
18413       implicit none
18414       integer nrmat,nmat,mat,irmat,mcurr
18415 !     parameter(nmat=12,nrmat=5)
18416       parameter(nmat=12,nrmat=7)
18417       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18418      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18419      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18420      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18421       parameter(fnavo=6.02e23)
18422       real cgen
18423       character * 4 mname(nmat)
18424       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18425       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18426       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18427       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18428       common/scatu2/xintl(nmat),radl(nmat),mname
18429       common/scatpp/pptot,ppel,ppsd
18430       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18431       common/phase/x,xp,z,zp,dpop
18432       common/nommom/p0
18433       common/cjaw1/zlm
18434       common/cmcs1/zlm1
18435       common/materia/mat
18436       common/sindif/xpsd,zpsd,psd
18437       common/cdpodx/dpodx
18438       integer inter,length,xmat
18439       double precision p,gettran,t,xm2,bsd
18440       real rndm4,truth,xran(1)
18441 !
18442 ! inter=2: Nuclear Elastic, 3: pp Elastic, 4: Single Diffractif, 5:Coulomb
18443 !
18444       if        ( inter.eq.2 ) then
18445            gettran = -log(dble(rndm4()))/bn(xmat)
18446 !
18447          elseif ( inter .eq. 3 ) then
18448            gettran = -log(dble(rndm4()))/bpp
18449 !
18450          elseif ( inter .eq. 4 ) then
18451            xm2 = exp( dble(rndm4()) * xln15s )
18452            p = p  *(1.d0 - xm2/ecmsq)
18453            if ( xm2 .lt. 2.d0 ) then
18454                 bsd = 2.d0 * bpp
18455               elseif (( xm2 .ge. 2.d0 ).and. ( xm2 .le. 5.d0 )) then
18456                 bsd = (106.d0-17.d0*xm2) *  bpp / 26.d0
18457               elseif ( xm2 .gt. 5.d0 ) then
18458                 bsd = 7.d0 * bpp / 12.d0
18459            endif
18460            gettran = -log(dble(rndm4()))/bsd
18461 !
18462          elseif ( inter.eq.5 ) then
18463            length=1
18464            call funlux( cgen(1,mat) , xran, length)
18465            truth=xran(1)
18466            t=truth
18467            gettran = t
18468       endif
18469       return
18470       end
18471 !---------------------------------------------------------------
18472 !
18473       subroutine tetat(t,p,tx,tz)
18474       implicit none
18475       double precision t,p,tx,tz,va,vb,va2,vb2,r2,teta
18476       real rndm4
18477       teta = sqrt(t)/p
18478 ! Generate sine and cosine of an angle uniform in [0,2pi](see RPP)
18479    10 va  =2d0*rndm4()-1d0
18480       vb = dble(rndm4())
18481       va2 = va*va
18482       vb2 = vb*vb
18483       r2 = va2 + vb2
18484       if ( r2.gt.1.d0) go to 10
18485       tx = teta * (2.d0*va*vb) / r2
18486       tz = teta * (va2 - vb2) / r2
18487       return
18488       end
18489 !---------------------------------------------------------------
18490 !
18491       function ruth(t)
18492       implicit none
18493       integer nrmat,nmat,mat,irmat,mcurr
18494 !     parameter(nmat=12,nrmat=5)
18495       parameter(nmat=12,nrmat=7)
18496       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18497      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18498      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18499      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18500       parameter(fnavo=6.02e23)
18501       real cgen
18502       character * 4 mname(nmat)
18503       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18504       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18505       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18506       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18507       common/scatu2/xintl(nmat),radl(nmat),mname
18508       common/scatpp/pptot,ppel,ppsd
18509       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18510       common/phase/x,xp,z,zp,dpop
18511       common/nommom/p0
18512       common/cjaw1/zlm
18513       common/cmcs1/zlm1
18514       common/materia/mat
18515       common/sindif/xpsd,zpsd,psd
18516       common/cdpodx/dpodx
18517       real ruth,t
18518       double precision cnorm,cnform
18519       parameter(cnorm=2.607d-4,cnform=0.8561d3)
18520 !c      write(6,'('' t,exp'',2e15.8)')t,t*cnform*EMr(mcurr)**2
18521       ruth=cnorm*exp(-t*cnform*emr(mcurr)**2)*(zatom(mcurr)/t)**2
18522       end
18523 !---------------------------------------------------------------
18524 !
18525       block data scdata
18526 !GRD
18527 !GRD CHANGED ON 2/2003 TO INCLUDE CODE FOR C, C2 from JBJ (rwa)
18528 !GRD
18529       implicit none
18530       integer nrmat,nmat,mat,irmat,mcurr
18531 !     parameter(nmat=12,nrmat=5)
18532       parameter(nmat=12,nrmat=7)
18533       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18534      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18535      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18536      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18537       parameter(fnavo=6.02e23)
18538       real cgen
18539       character * 4 mname(nmat)
18540       integer i
18541       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18542       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18543       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18544       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18545       common/scatu2/xintl(nmat),radl(nmat),mname
18546       common/scatpp/pptot,ppel,ppsd
18547       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18548       common/phase/x,xp,z,zp,dpop
18549       common/nommom/p0
18550       common/cjaw1/zlm
18551       common/cmcs1/zlm1
18552       common/materia/mat
18553       common/sindif/xpsd,zpsd,psd
18554       common/cdpodx/dpodx
18555 ! The last materials are 'vacuum' and 'black', see in sub. SCATIN
18556 ! Number of real materials defined here:
18557 !
18558 !++ CHANGE THE NUMBER OF REAL MATERIALS FROM 5 to 7 (bug in JBJ'S ROUTINE?)
18559 !
18560 !      data irmat/5/
18561 !
18562       data irmat/7/
18563 !
18564 ! Reference data at pRef=450Gev
18565 !      data (mname(i),i=1,nrmat)/ 'Be' , 'Al' , 'Cu' , 'W'  , 'Pb' /
18566       data (mname(i),i=1,nrmat)/ 'Be','Al','Cu','W','Pb','C','C2' /
18567 !
18568 !      data mname(nmat-1), mname(nmat)/'vacu','blac'/
18569       data mname(nmat-1), mname(nmat)/'vacu','blac'/
18570 !GRD
18571 !GRD IMPLEMENT CHANGES FROM JBJ, 2/2003 RWA
18572 !GRD
18573 !      data (Anuc(i),i=1,nrmat)/ 9.01, 26.98, 63.55, 183.85, 207.19/
18574       data (anuc(i),i=1,5)/ 9.01d0,26.98d0,63.55d0,183.85d0,207.19d0/
18575       data (anuc(i),i=6,nrmat)/12.01d0,12.01d0/
18576 !
18577 !GRD      data (Z(i),i=1,nrmat)/       4,    13,    29,     74,     82/
18578       data (zatom(i),i=1,5)/ 4d0, 13d0, 29d0, 74d0, 82d0/
18579       data (zatom(i),i=6,nrmat)/   6d0,      6d0/
18580 !GRD      data (Rho(i),i=1,nrmat)/ 1.848,  2.70,  8.96,   19.3,  11.35/
18581       data (rho(i),i=1,5)/ 1.848d0, 2.70d0, 8.96d0, 19.3d0, 11.35d0/
18582       data (rho(i),i=6,nrmat)/ 2.26d0, 4.52d0/
18583 !GRD      data (RadL(i),i=1,nrmat)/ 0.353, 0.089, 0.0143, 0.0035, 0.0056/
18584       data (radl(i),i=1,5)/ 0.353d0,0.089d0,0.0143d0,0.0035d0,0.0056d0/
18585       data (radl(i),i=6,nrmat)/ 0.188d0, 0.094d0/
18586       data radl(nmat-1),radl(nmat)/ 1.d12, 1.d12 /
18587 !GRD      data (EMR(i),i=1,nrmat)/  0.22, 0.302, 0.366,    0.0,  0.542/
18588 !MAY06-GRD value for Tungsten (W) not stated
18589 !      data (emr(i),i=1,5)/  0.22d0, 0.302d0, 0.366d0, 0.0d0, 0.542d0/
18590       data (emr(i),i=1,5)/  0.22d0, 0.302d0, 0.366d0, 0.520d0, 0.542d0/
18591 !MAY06-GRD end of changes
18592       data (emr(i),i=6,nrmat)/  0.25d0, 0.25d0/
18593 !GRD      data tLcut,(Hcut(i),i=1,nrmat)/0.9982e-3,0.02,0.02,3*0.01/
18594       data tlcut / 0.0009982d0/
18595       data (hcut(i),i=1,5)/0.02d0, 0.02d0, 3*0.01d0/
18596       data (hcut(i),i=6,nrmat)/0.02d0, 0.02d0/
18597 !      data (dpodx(i),i=1,nrmat)/ nrmat*0.d0 /
18598 !GRD      data (dpodx(i),i=1,nrmat)/ .55, .81, 2.69, 5.79, 3.4 /
18599       data (dpodx(i),i=1,5)/ .55d0, .81d0, 2.69d0, 5.79d0, 3.4d0 /
18600       data (dpodx(i),i=6,nrmat)/ .75d0, 1.5d0 /
18601 !
18602 ! All cross-sections are in barns,nuclear values from RPP at 20geV
18603 ! Coulomb is integerated above t=tLcut[Gev2] (+-1% out Gauss mcs)
18604 !
18605 ! in Cs and CsRef,1st index: Cross-sections for processes
18606 ! 0:Total, 1:absorption, 2:nuclear elastic, 3:pp or pn elastic
18607 ! 4:Single Diffractive pp or pn, 5:Coulomb for t above mcs
18608 !
18609 !MAY06-GRD: found an error in the values for Rutherford cross-sections,
18610 !as the ones reported here are stated in fm^2 and not in barns, hence
18611 !being 100 times too large...
18612 !      data csref(0,1),csref(1,1),csref(5,1)/0.268d0, 0.199d0 , 0.0035d0/
18613 !      data csref(0,2),csref(1,2),csref(5,2)/0.634d0, 0.421d0 , 0.034d0/
18614 !      data csref(0,3),csref(1,3),csref(5,3)/1.232d0, 0.782d0 , 0.153d0/
18615 !      data csref(0,4),csref(1,4),csref(5,4)/2.767d0, 1.65d0  , 0.768d0/
18616 !      data csref(0,5),csref(1,5),csref(5,5)/2.960d0, 1.77d0  , 0.907d0/
18617 !!GRD
18618 !      data csref(0,6),csref(1,6),csref(5,6)/0.331d0, 0.231d0, 0.0076d0/
18619 !      data csref(0,7),csref(1,7),csref(5,7)/0.331d0, 0.231d0, 0.0076d0/
18620 !
18621       data csref(0,1),csref(1,1),csref(5,1)/0.268d0, 0.199d0, 0.0035d-2/
18622       data csref(0,2),csref(1,2),csref(5,2)/0.634d0, 0.421d0, 0.034d-2/
18623       data csref(0,3),csref(1,3),csref(5,3)/1.232d0, 0.782d0, 0.153d-2/
18624       data csref(0,4),csref(1,4),csref(5,4)/2.767d0, 1.65d0 , 0.768d-2/
18625       data csref(0,5),csref(1,5),csref(5,5)/2.960d0, 1.77d0 , 0.907d-2/
18626 !GRD
18627       data csref(0,6),csref(1,6),csref(5,6)/0.331d0, 0.231d0, 0.0076d-2/
18628       data csref(0,7),csref(1,7),csref(5,7)/0.331d0, 0.231d0, 0.0076d-2/
18629 !MAY06-GRD end of changes
18630 !
18631 ! pp cross-sections and parameters for energy dependence
18632       data pptref,pperef,sdcoe,pref/0.04d0,0.007d0,0.00068d0,450.0d0/
18633       data pptco,ppeco,freeco/0.05788d0,0.04792d0,1.618d0/
18634 ! Nuclear elastic slope from Schiz et al.,PRD 21(3010)1980
18635 !GRD      data (bNRef(i),i=1,nrmat)/74.7,120.3,217.8,0.0,455.3/
18636 !MAY06-GRD value for Tungsten (W) not stated
18637 !      data (bnref(i),i=1,5)/74.7d0,120.3d0,217.8d0,0.0d0,455.3d0/
18638       data (bnref(i),i=1,5)/74.7d0,120.3d0,217.8d0,440.3d0,455.3d0/
18639 !MAY06-GRD end of changes
18640       data (bnref(i),i=6,nrmat)/70.d0, 70.d0/
18641 !GRD LAST 2 ONES INTERPOLATED
18642 !
18643 ! Cprob to choose an interaction in iChoix
18644       data (cprob(0,i),i=1,nmat)/nmat*0.0d0/
18645       data (cprob(5,i),i=1,nmat)/nmat*1.0d0/
18646 !
18647       end
18648
18649 !---------------------------------------------------------------
18650 !
18651       subroutine scatin(plab)
18652       implicit none
18653       integer nrmat,nmat,mat,irmat,mcurr
18654 !     parameter(nmat=12,nrmat=5)
18655       parameter(nmat=12,nrmat=7)
18656       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18657      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18658      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18659      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18660       parameter(fnavo=6.02e23)
18661       real cgen
18662       character * 4 mname(nmat)
18663       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18664       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18665       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18666       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18667       common/scatu2/xintl(nmat),radl(nmat),mname
18668       common/scatpp/pptot,ppel,ppsd
18669       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18670       common/phase/x,xp,z,zp,dpop
18671       common/nommom/p0
18672       common/cjaw1/zlm
18673       common/cmcs1/zlm1
18674       common/materia/mat
18675       common/sindif/xpsd,zpsd,psd
18676       common/cdpodx/dpodx
18677       integer ma,i
18678       double precision plab
18679       real ruth,tlow,thigh
18680       external ruth
18681 !      open(unit=6,file='scatin.out')
18682 !
18683       ecmsq = 2 * 0.93828d0 * plab
18684       xln15s=log(0.15*ecmsq)
18685 ! pp(pn) data
18686       pptot = pptref *(plab / pref)** pptco
18687       ppel = pperef *(plab / pref)** ppeco
18688       ppsd = sdcoe * log(0.15d0 * ecmsq)
18689       bpp = 8.5d0 + 1.086d0 * log(sqrt(ecmsq))
18690 ! unmeasured tungsten data,computed with lead data and power laws
18691       bnref(4) = bnref(5)*(anuc(4) / anuc(5))**(2d0/3d0)
18692       emr(4) = emr(5) * (anuc(4)/anuc(5))**(1d0/3d0)
18693    10 format(/' ppRef TOT El     ',4f12.6//)
18694 !      write(6,10)ppTRef,ppEref
18695    11 format(/' pp    TOT El Sd b',4f12.6//)
18696 !      write(6,11)ppTot,ppEl,ppSD,bpp
18697 !
18698 ! Compute cross-sections (CS) and probabilities + Interaction length
18699 ! Last two material treated below statement number 100
18700 !
18701       tlow=tlcut
18702       do 100 ma=1,irmat
18703         mcurr=ma
18704 ! prepare for Rutherford differential distribution
18705         thigh=hcut(ma)
18706         call funlxp ( ruth , cgen(1,ma) ,tlow, thigh )
18707 !
18708 ! freep: number of nucleons involved in single scattering
18709         freep(ma) = freeco * anuc(ma)**(1d0/3d0)
18710 ! compute pp and pn el+single diff contributions to cross-section
18711 ! (both added : quasi-elastic or qel later)
18712         cs(3,ma) = freep(ma) * ppel
18713         cs(4,ma) = freep(ma) * ppsd
18714 !
18715 ! correct TOT-CSec for energy dependence of qel
18716 ! TOT CS is here without a Coulomb contribution
18717         cs(0,ma) = csref(0,ma) + freep(ma) * (pptot - pptref)
18718         bn(ma) = bnref(ma) * cs(0,ma) / csref(0,ma)
18719 ! also correct inel-CS
18720         cs(1,ma) = csref(1,ma) * cs(0,ma) / csref(0,ma)
18721 !
18722 ! Nuclear Elastic is TOT-inel-qel ( see definition in RPP)
18723         cs(2,ma) = cs(0,ma) - cs(1,ma) - cs(3,ma) - cs(4,ma)
18724         cs(5,ma) = csref(5,ma)
18725 ! Now add Coulomb
18726         cs(0,ma) = cs(0,ma) + cs(5,ma)
18727 ! Interaction length in meter
18728         xintl(ma) = 0.01d0*anuc(ma)/(fnavo * rho(ma)*cs(0,ma)*1d-24)
18729 !
18730    20   format(/1x,a4,' Int.Len. ',f10.6,' CsTot',2f12.4/)
18731 !        write(6,20)mname(ma),xIntL(ma),Cs(0,ma),CsRef(0,ma)
18732    21   format('  bN freep',2 f12.6,'   emR ',f7.4/)
18733 !        write(6,21)bN(ma),freep(ma),emR(ma)
18734 ! Filling CProb with cumulated normalised Cross-sections
18735         do 50 i=1,4
18736           cprob(i,ma)=cprob(i-1,ma)+cs(i,ma)/cs(0,ma)
18737 !          write(6,22)i,Cprob(i,ma),Cs(i,ma),CsRef(i,ma)
18738  50     continue
18739 !        write(6,22)5,Cprob(5,ma),Cs(5,ma),CsRef(5,ma)
18740    22   format(i4,' prob CS CsRref',3(f12.5,2x))
18741   100 continue
18742 !
18743 ! Last two materials for 'vaccum' (nmat-1) and 'full black' (nmat)
18744 !
18745       cprob(1,nmat-1)=1d0
18746       cprob(1,nmat)=1d0
18747       xintl(nmat-1)=1d12
18748       xintl(nmat)=0.0d0
18749   120 format(/1x,a4,' Int.Len. ',e10.3/)
18750 !      write(6,120)mname(nmat-1),xIntL(nmat-1)
18751 !      write(6,120)mname(nmat),xIntL(nmat)
18752       return
18753       end
18754  
18755 !-----------------------------------------------------------------------
18756 !
18757       subroutine jaw(s,nabs)
18758 !
18759 !++  Input:   ZLM is interaction length
18760 !++           MAT is choice of material
18761 !
18762 !++  Output:  nabs = 1   Particle is absorped
18763 !++           nabs = 4   Single-diffractive scattering
18764 !++           dpop       Adjusted for momentum loss (dE/dx)
18765 !++           s          Exit longitudinal position
18766 !
18767 !++  Physics:  If monte carlo interaction length greater than input
18768 !++            interaction length, then use input interaction length
18769 !++            Is that justified???
18770 !
18771 !     nabs=1....absorption
18772 !
18773       implicit none
18774 !
18775       integer nrmat,nmat,mat,irmat,mcurr
18776 !     parameter(nmat=12,nrmat=5)
18777       parameter(nmat=12,nrmat=7)
18778       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18779      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18780      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18781      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18782       parameter(fnavo=6.02e23)
18783       real cgen
18784       character * 4 mname(nmat)
18785       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18786       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18787       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18788       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18789       common/scatu2/xintl(nmat),radl(nmat),mname
18790       common/scatpp/pptot,ppel,ppsd
18791       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18792       common/phase/x,xp,z,zp,dpop
18793       common/nommom/p0
18794       common/cjaw1/zlm
18795       common/cmcs1/zlm1
18796       common/materia/mat
18797       common/sindif/xpsd,zpsd,psd
18798       common/cdpodx/dpodx
18799       integer nabs,inter,ichoix
18800       double precision p,rlen,s,t,gettran,dxp,dzp,p1
18801       real rndm4
18802 !...cne=1/(sqrt(b))
18803 !...dpodx=dE/(dx*c)
18804 !
18805 !++  Note that the input parameter is dpop. Here the momentum p is
18806 !++  constructed out of this input.
18807 !
18808 !      p=p0/(1.d0-dpop)
18809       p=p0*(1.d0+dpop)
18810       nabs=0
18811       if(mat.eq.nmat) then
18812 !
18813 !++  Collimator treated as black absorber
18814 !
18815         nabs=1
18816         s=0d0
18817         return
18818       else if(mat.eq.nmat-1) then
18819 !
18820 !++  Collimator treated as drift
18821 !
18822         s=zlm
18823         x=x+s*xp
18824         z=z+s*zp
18825         return
18826       end if
18827 !
18828 !++  Initialize the interaction length to input interaction length
18829 !
18830       rlen=zlm
18831 !
18832 !++  Do a step for a point-like interaction. This is a loop with
18833 !++  label 10!!!
18834 !
18835 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
18836 !++  Get monte-carlo interaction length.
18837 !
18838 10    zlm1=-xintl(mat)*log(dble(rndm4()))
18839 !
18840       if(zlm1.gt.rlen) then
18841 !
18842 !++  If the monte-carlo interaction length is shorter than the
18843 !++  remaining collimator length, then put it to the remaining
18844 !++  length, do multiple coulomb scattering and return.
18845 !++  LAST STEP IN ITERATION LOOP
18846 !
18847        zlm1=rlen
18848        call mcs(s)
18849        s=zlm-rlen+s
18850        p=p-dpodx(mat)*s
18851 !       dpop=1.d0-p0/p
18852        dpop=(p-p0)/p0
18853        return
18854       end if
18855 !
18856 !++  Otherwise do multi-coulomb scattering.
18857 !++  REGULAR STEP IN ITERATION LOOP
18858 !
18859       call mcs(s)
18860 !
18861 !++  Check if particle is outside of collimator (X.LT.0) after
18862 !++  MCS. If yes, calculate output longitudinal position (s),
18863 !++  reduce momentum (output as dpop) and return.
18864 !++  PARTICLE LEFT COLLIMATOR BEFORE ITS END.
18865 !
18866       if(x.le.0d0) then
18867        s=zlm-rlen+s
18868        p=p-dpodx(mat)*s
18869        dpop=(p-p0)/p0
18870        return
18871       end if
18872 !
18873 !++  Check whether particle is absorbed. If yes, calculate output
18874 !++  longitudinal position (s), reduce momentum (output as dpop)
18875 !++  and return.
18876 !++  PARTICLE WAS ABSORPED INSIDE COLLIMATOR DURING MCS.
18877 !
18878       inter=ichoix(mat)
18879       if(inter.eq.1) then
18880        nabs=1
18881        s=zlm-rlen+zlm1
18882        p=p-dpodx(mat)*s
18883        dpop=(p-p0)/p0
18884        return
18885       end if
18886 !
18887 !++  Now treat the other types of interaction, as determined by ICHOIX:
18888 !
18889 !++      Nuclear-Elastic:          inter = 2
18890 !++      pp Elastic:               inter = 3
18891 !++      Single-Diffractive:       inter = 4    (changes momentum p)
18892 !++      Coulomb:                  inter = 5
18893 !
18894 !++  As the single-diffractive interaction changes the momentum, save
18895 !++  input momentum in p1.
18896 !
18897       p1 = p
18898 !
18899 !++  Gettran returns some monte carlo number, that, as I believe, gives
18900 !++  the rms transverse momentum transfer.
18901 !
18902       t = gettran(inter,mat,p)
18903 !
18904 !++  Tetat calculates from the rms transverse momentum transfer in
18905 !++  monte-carlo fashion the angle changes for x and z planes. The
18906 !++  angle change is proportional to SQRT(t) and 1/p, as expected.
18907 !
18908       call tetat(t,p,dxp,dzp)
18909 !
18910 !++  Apply angle changes
18911 !
18912       xp=xp+dxp
18913       zp=zp+dzp
18914 !
18915 !++  Treat single-diffractive scattering.
18916 !
18917       if(inter.eq.4) then
18918         nabs=4
18919 !
18920 !++ added update for s
18921 !
18922         s=zlm-rlen+zlm1
18923         xpsd=dxp
18924         zpsd=dzp
18925         psd=p1
18926 !
18927 !++  Add this code to get the momentum transfer also in the calling
18928 !++  routine...
18929 !
18930         dpop=(p-p0)/p0
18931 !
18932       end if
18933 !
18934 !++  Calculate the remaining interaction length and close the iteration
18935 !++  loop.
18936 !
18937       rlen=rlen-zlm1
18938       goto 10
18939 !
18940       end
18941 !------------------------------------------------------------------------
18942 !-----------------------------------------------------------------------
18943 !
18944       subroutine jaw0(s,nabs)
18945 !
18946 !++  Input:   ZLM is interaction length
18947 !++           MAT is choice of material
18948 !
18949 !++  Output:  nabs = 1   Particle is absorped
18950 !++           nabs = 4   Single-diffractive scattering
18951 !++           dpop       Adjusted for momentum loss (dE/dx)
18952 !++           s          Exit longitudinal position
18953 !
18954 !++  Physics:  If monte carlo interaction length greater than input
18955 !++            interaction length, then use input interaction length
18956 !++            Is that justified???
18957 !
18958 !     nabs=1....absorption
18959 !
18960       implicit none
18961 !
18962       integer nrmat,nmat,mat,irmat,mcurr
18963 !     parameter(nmat=12,nrmat=5)
18964       parameter(nmat=12,nrmat=7)
18965       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
18966      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
18967      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
18968      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
18969       parameter(fnavo=6.02e23)
18970       real cgen
18971       character * 4 mname(nmat)
18972       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
18973       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
18974       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
18975       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
18976       common/scatu2/xintl(nmat),radl(nmat),mname
18977       common/scatpp/pptot,ppel,ppsd
18978       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
18979       common/phase/x,xp,z,zp,dpop
18980       common/nommom/p0
18981       common/cjaw1/zlm
18982       common/cmcs1/zlm1
18983       common/materia/mat
18984       common/sindif/xpsd,zpsd,psd
18985       common/cdpodx/dpodx
18986       integer nabs,inter,ichoix
18987       double precision p,rlen,s,t,gettran,dxp,dzp,p1
18988       real rndm4
18989 !...cne=1/(sqrt(b))
18990 !...dpodx=dE/(dx*c)
18991       p=p0/(1.d0-dpop)
18992       nabs=0
18993       if(mat.eq.nmat) then
18994 !
18995 !++  Collimator treated as black absorber
18996 !
18997         nabs=1
18998         s=0d0
18999         return
19000       else if(mat.eq.nmat-1) then
19001 !
19002 !++  Collimator treated as drift
19003 !
19004         s=zlm
19005         x=x+s*xp
19006         z=z+s*zp
19007         return
19008       end if
19009 !
19010 !++  Initialize the interaction length to input interaction length
19011 !
19012       rlen=zlm
19013 !
19014 !++  Do a step for a point-like interaction. This is a loop with
19015 !++  label 10!!!
19016 !
19017 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
19018 !++  Get monte-carlo interaction length.
19019 !
19020 10    zlm1=-xintl(mat)*log(dble(rndm4()))
19021 !
19022       if(zlm1.gt.rlen) then
19023 !
19024 !++  If the monte-carlo interaction length is shorter than the
19025 !++  remaining collimator length, then put it to the remaining
19026 !++  length, do multiple coulomb scattering and return.
19027 !++  LAST STEP IN ITERATION LOOP
19028 !
19029        zlm1=rlen
19030        call mcs(s)
19031        s=zlm-rlen+s
19032        p=p-dpodx(mat)*s
19033        dpop=1.d0-p0/p
19034        return
19035       end if
19036 !
19037 !++  Otherwise do multi-coulomb scattering.
19038 !++  REGULAR STEP IN ITERATION LOOP
19039 !
19040       call mcs(s)
19041 !
19042 !++  Check if particle is outside of collimator (X.LT.0) after
19043 !++  MCS. If yes, calculate output longitudinal position (s),
19044 !++  reduce momentum (output as dpop) and return.
19045 !++  PARTICLE LEFT COLLIMATOR BEFORE ITS END.
19046 !
19047       if(x.le.0.d0) then
19048        s=zlm-rlen+s
19049        p=p-dpodx(mat)*s
19050        dpop=1.d0-p0/p
19051        return
19052       end if
19053 !
19054 !++  Check whether particle is absorbed. If yes, calculate output
19055 !++  longitudinal position (s), reduce momentum (output as dpop)
19056 !++  and return.
19057 !++  PARTICLE WAS ABSORPED INSIDE COLLIMATOR DURING MCS.
19058 !
19059       inter=ichoix(mat)
19060       if(inter.eq.1) then
19061        nabs=1
19062        s=zlm-rlen+zlm1
19063        p=p-dpodx(mat)*s
19064        dpop=1.d0-p0/p
19065        return
19066       end if
19067 !
19068 !++  Now treat the other types of interaction, as determined by ICHOIX:
19069 !
19070 !++      Nuclear-Elastic:          inter = 2
19071 !++      pp Elastic:               inter = 3
19072 !++      Single-Diffractive:       inter = 4    (changes momentum p)
19073 !++      Coulomb:                  inter = 5
19074 !
19075 !++  As the single-diffractive interaction changes the momentum, save
19076 !++  input momentum in p1.
19077 !
19078       p1 = p
19079 !
19080 !++  Gettran returns some monte carlo number, that, as I believe, gives
19081 !++  the rms transverse momentum transfer.
19082 !
19083       t = gettran(inter,mat,p)
19084 !
19085 !++  Tetat calculates from the rms transverse momentum transfer in
19086 !++  monte-carlo fashion the angle changes for x and z planes. The
19087 !++  angle change is proportional to SQRT(t) and 1/p, as expected.
19088 !
19089       call tetat(t,p,dxp,dzp)
19090 !
19091 !++  Apply angle changes
19092 !
19093       xp=xp+dxp
19094       zp=zp+dzp
19095 !
19096 !++  Treat single-diffractive scattering.
19097 !
19098       if(inter.eq.4) then
19099         nabs=4
19100         xpsd=dxp
19101         zpsd=dzp
19102         psd=p1
19103       end if
19104 !
19105 !++  Calculate the remaining interaction length and close the iteration
19106 !++  loop.
19107 !
19108       rlen=rlen-zlm1
19109       goto 10
19110 !
19111       end
19112 !------------------------------------------------------------------------
19113  
19114       subroutine mcs(s)
19115 !
19116 !++  Input:   zlm1   Monte-carlo interaction length
19117 !
19118 !++  Output:  s      Longitudinal position
19119 !++           p0     Reference momentum
19120 !++           dpop   Relative momentum offset
19121 !
19122 !     collimator: x>0 and y<zlm1
19123 !
19124       implicit none
19125 !      save h,dh,bn
19126       integer nrmat,nmat,mat,irmat,mcurr
19127 !     parameter(nmat=12,nrmat=5)
19128       parameter(nmat=12,nrmat=7)
19129       double precision xintl,radl,x,xp,z,zp,dpop,p0,zlm,zlm1,xpsd,zpsd, &
19130      &psd,dpodx(nmat),anuc,rho,emr,tlcut,hcut,cs,csref,bnref,freep,     &
19131      &cprob,bn,bpp,xln15s,ecmsq,pptot,ppel,ppsd,pptref,pperef,pref,     &
19132      &pptco,ppeco,sdcoe,freeco,fnavo,zatom
19133       parameter(fnavo=6.02e23)
19134       real cgen
19135       character * 4 mname(nmat)
19136       common/mater/anuc(nmat),zatom(nmat),rho(nmat),emr(nmat),irmat
19137       common/coul/tlcut,hcut(nmat),cgen(200,nmat),mcurr
19138       common/scat/cs(0:5,nmat),csref(0:5,nmat),bnref(nmat),freep(nmat)
19139       common/scatu/cprob(0:5,nmat),bn(nmat),bpp,xln15s,ecmsq
19140       common/scatu2/xintl(nmat),radl(nmat),mname
19141       common/scatpp/pptot,ppel,ppsd
19142       common/sppref/pptref,pperef,pref,pptco,ppeco,sdcoe,freeco
19143       common/phase/x,xp,z,zp,dpop
19144       common/nommom/p0
19145       common/cjaw1/zlm
19146       common/cmcs1/zlm1
19147       common/materia/mat
19148       common/sindif/xpsd,zpsd,psd
19149       common/cdpodx/dpodx
19150       double precision h,dh,theta,rlen0,rlen,ae,be,bn0,s
19151 !   bn=sqrt(3)/(number of sigmas for s-determination(=4))
19152       data h/.001d0/dh/.0001d0/bn0/.4330127019d0/
19153 !
19154 !++
19155 !
19156       theta=13.6d-3*(1.d0-dpop)/p0
19157       x=x/theta/radl(mat)
19158       xp=xp/theta
19159       z=z/theta/radl(mat)
19160       zp=zp/theta
19161       rlen0=zlm1/radl(mat)
19162       rlen=rlen0
19163 10    ae=bn0*x
19164       be=bn0*xp
19165       call soln3(ae,be,dh,rlen,s)
19166       if(s.lt.h) s=h
19167       call scamcs(x,xp,s)
19168       if(x.le.0.d0) then
19169        s=rlen0-rlen+s
19170        goto 20
19171       end if
19172       if(s+dh.ge.rlen) then
19173        s=rlen0
19174        goto 20
19175       end if
19176       rlen=rlen-s
19177       goto 10
19178 20    call scamcs(z,zp,s)
19179       s=s*radl(mat)
19180       x=x*theta*radl(mat)
19181       xp=xp*theta
19182       z=z*theta*radl(mat)
19183       zp=zp*theta
19184       end
19185  
19186       subroutine scamcs(xx,xxp,s)
19187       implicit none
19188       double precision v1,v2,r2,a,z1,z2,ss,s,xx,xxp,x0,xp0
19189       real rndm4
19190       x0=xx
19191       xp0=xxp
19192 5     v1=2d0*rndm4()-1d0
19193       v2=2d0*rndm4()-1d0
19194       r2=v1*v1+v2*v2
19195       if(r2.ge.1.d0) goto 5
19196       a=dsqrt(-2.d0*log(r2)/r2)
19197       z1=v1*a
19198       z2=v2*a
19199       ss=dsqrt(s)
19200       xx=x0+s*(xp0+.5d0*ss*(z2+z1*.577350269d0))
19201 !     x=x0+s*(xp0+.5d0*ss*(z2+z1/dsqrt(3.d0)))
19202       xxp=xp0+ss*z2
19203       end
19204  
19205 !-------------------------------------------------------------
19206  
19207       subroutine soln3(a,b,dh,smax,s)
19208       implicit none
19209       double precision b,a,s,smax,c,dh
19210       if(b.eq.0.d0) then
19211        s=a**0.6666666666666667d0
19212 !      s=a**(2.d0/3.d0)
19213        if(s.gt.smax) s=smax
19214        return
19215       end if
19216       if(a.eq.0.d0) then
19217        if(b.gt.0.d0) then
19218          s=b**2
19219        else
19220          s=0.d0
19221        end if
19222        if(s.gt.smax) s=smax
19223        return
19224       end if
19225       if(b.gt.0.d0) then
19226        if(smax**3.le.(a+b*smax)**2) then
19227         s=smax
19228         return
19229        else
19230         s=smax*.5d0
19231         call iterat(a,b,dh,s)
19232        end if
19233       else
19234        c=-a/b
19235        if(smax.lt.c) then
19236         if(smax**3.le.(a+b*smax)**2) then
19237          s=smax
19238          return
19239         else
19240          s=smax*.5d0
19241          call iterat(a,b,dh,s)
19242         end if
19243        else
19244         s=c*.5d0
19245         call iterat(a,b,dh,s)
19246        end if
19247       end if
19248       end
19249  
19250  
19251       subroutine iterat(a,b,dh,s)
19252       implicit none
19253       double precision ds,s,a,b,dh
19254  
19255       ds=s
19256 10    ds=ds*.5d0
19257       if(s**3.lt.(a+b*s)**2) then
19258         s=s+ds
19259       else
19260         s=s-ds
19261       end if
19262       if(ds.lt.dh) then
19263         return
19264       else
19265         goto 10
19266       end if
19267       end
19268 !
19269 !cccccccccccccccccccccccccccccccccc
19270 !
19271       function rndm4()
19272       implicit none
19273       integer len, in
19274       real rndm4, a
19275       save
19276       parameter ( len =  30000 )
19277       dimension a(len)
19278       data in/1/
19279 !
19280       if ( in.eq.1 ) then
19281          call ranlux(a,len)
19282          rndm4=a(1)
19283          in=2
19284 !        write(6,'('' LEN: '',i5)')LEN
19285       else
19286          rndm4=a(in)
19287          in=in+1
19288          if(in.eq.len+1)in=1
19289       endif
19290       return
19291       end
19292 !
19293 !
19294 !ccccccccccccccccccccccccccccccccccccccc
19295 !-TW-01/2007
19296 ! function rndm5(irnd) , irnd = 1 will reset
19297 ! inn counter => enables reproducible set of
19298 ! random unmbers
19299 !cccccccccccccccccccccccccccccccccc
19300 !
19301       function rndm5(irnd)
19302       implicit none
19303       integer len, inn, irnd
19304       real rndm5, a
19305       save
19306       parameter ( len =  30000 )
19307       dimension a(len)
19308       data inn/1/
19309 !
19310 ! reset inn to 1 enable reproducible random numbers
19311       if ( irnd .eq. 1) inn = 1
19312       if ( inn.eq.1 ) then
19313          call ranlux(a,len)
19314          rndm5=a(1)
19315          inn=2
19316       else
19317          rndm5=a(inn)
19318          inn=inn+1
19319          if(inn.eq.len+1)inn=1
19320       endif
19321       return
19322       end
19323 !
19324 !ccccccccccccccccccccccccccccccccccccccc
19325 !
19326 !
19327       double precision function myran_gauss(cut)
19328 !*********************************************************************
19329 !
19330 ! myran_gauss - will generate a normal distribution from a uniform
19331 !     distribution between [0,1].
19332 !     See "Communications of the ACM", V. 15 (1972), p. 873.
19333 !
19334 !     cut - double precision - cut for distribution in units of sigma
19335 !     the cut must be greater than 0.5
19336 !
19337 !     changed rndm4 to rndm5(irnd) and defined flag as true
19338 !
19339 !*********************************************************************
19340       implicit none
19341       
19342       logical flag
19343       real rndm5
19344       double precision x, u1, u2, twopi, r,cut
19345       save
19346       
19347       flag = .true.
19348
19349       twopi=8d0*atan(1d0)
19350  1    if (flag) then
19351          r = dble(rndm5(0))
19352          r = max(r, 0.5d0**32)
19353          r = min(r, 1d0-0.5d0**32)
19354          u1 = sqrt(-2d0*log( r ))
19355          u2 = dble(rndm5(0))
19356          x = u1 * cos(twopi*u2)
19357       else
19358          x = u1 * sin(twopi*u2)
19359       endif
19360       
19361       flag = .not. flag
19362       
19363 !     cut the distribution if cut > 0.5
19364       if (cut .gt. 0.5d0 .and. abs(x) .gt. cut) goto 1
19365       
19366       myran_gauss = x
19367       return
19368       end
19369 !
19370 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19371
19372 !
19373 ! $Id: ranlux.F,v 1.2 1997/09/22 13:45:47 mclareni Exp $
19374 !
19375 ! $Log: ranlux.F,v $
19376 ! Revision 1.2  1997/09/22 13:45:47  mclareni
19377 ! Correct error in initializing RANLUX by using RLUXIN with the output of
19378 ! RLUXUT from a previous run.
19379 !
19380 ! Revision 1.1.1.1  1996/04/01 15:02:55  mclareni
19381 ! Mathlib gen
19382 !
19383 !
19384       subroutine ranlux(rvec,lenv)
19385 !         Subtract-and-borrow random number generator proposed by
19386 !         Marsaglia and Zaman, implemented by F. James with the name
19387 !         RCARRY in 1991, and later improved by Martin Luescher
19388 !         in 1993 to produce "Luxury Pseudorandom Numbers".
19389 !     Fortran 77 coded by F. James, 1993
19390 !
19391 !   LUXURY LEVELS.
19392 !   ------ ------      The available luxury levels are:
19393 !
19394 !  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
19395 !           and Zaman, very long period, but fails many tests.
19396 !  level 1  (p=48): considerable improvement in quality over level 0,
19397 !           now passes the gap test, but still fails spectral test.
19398 !  level 2  (p=97): passes all known tests, but theoretically still
19399 !           defective.
19400 !  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
19401 !           correlations have very small chance of being observed.
19402 !  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
19403 !
19404 !!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
19405 !!!  Calling sequences for RANLUX:                                  ++
19406 !!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
19407 !!!                   32-bit random floating point numbers between  ++
19408 !!!                   zero (not included) and one (also not incl.). ++
19409 !!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
19410 !!!               one 32-bit integer INT and sets Luxury Level LUX  ++
19411 !!!               which is integer between zero and MAXLEV, or if   ++
19412 !!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
19413 !!!               should be set to zero unless restarting at a break++
19414 !!!               point given by output of RLUXAT (see RLUXAT).     ++
19415 !!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
19416 !!!               which can be used to restart the RANLUX generator ++
19417 !!!               at the current point by calling RLUXGO.  K1 and K2++
19418 !!!               specify how many numbers were generated since the ++
19419 !!!               initialization with LUX and INT.  The restarting  ++
19420 !!!               skips over  K1+K2*E9   numbers, so it can be long.++
19421 !!!   A more efficient but less convenient way of restarting is by: ++
19422 !!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
19423 !!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
19424 !!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
19425 !!!                 32-bit integer seeds, to be used for restarting ++
19426 !!!      ISVEC must be dimensioned 25 in the calling program        ++
19427 !!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
19428       implicit none
19429       integer lenv,isdext,iseeds,maxlev,ndskip,itwo24,next,j24,i24,     &
19430      &inseed,mkount,kount,in24,nskip,lxdflt,jsdflt,jseed,lp,i,k,icons,  &
19431      &inner,izip,izip2,ivec,isk,igiga,isd,k2,k1,inout,lout,ins,lux,ilx, &
19432      &iouter
19433       real rvec,seeds,twop12,twom12,twom24,carry,uni
19434       dimension rvec(lenv)
19435       dimension seeds(24), iseeds(24), isdext(25)
19436       parameter (maxlev=4, lxdflt=3)
19437       dimension ndskip(0:maxlev)
19438       dimension next(24)
19439       parameter (twop12=4096., igiga=1000000000,jsdflt=314159265)
19440       parameter (itwo24=2**24, icons=2147483563)
19441       save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
19442       save nskip, ndskip, in24, next, kount, mkount, inseed
19443       integer luxlev
19444       logical notyet
19445       data notyet, luxlev, in24, kount, mkount /.true., lxdflt, 0,0,0/
19446       data i24,j24,carry/24,10,0./
19447 !                               default
19448 !  Luxury Level   0     1     2   *3*    4
19449       data ndskip/0,   24,   73,  199,  365 /
19450 !Corresponds to p=24    48    97   223   389
19451 !     time factor 1     2     3     6    10   on slow workstation
19452 !                 1    1.5    2     3     5   on fast mainframe
19453 !
19454 !  NOTYET is .TRUE. if no initialization has been performed yet.
19455 !              Default Initialization by Multiplicative Congruential
19456       if (notyet) then
19457          notyet = .false.
19458          jseed = jsdflt
19459          inseed = jseed
19460          write(*,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',jseed
19461          luxlev = lxdflt
19462          nskip = ndskip(luxlev)
19463          lp = nskip + 24
19464          in24 = 0
19465          kount = 0
19466          mkount = 0
19467 !         WRITE(6,'(A,I2,A,I4)')  ' RANLUX DEFAULT LUXURY LEVEL =  ',
19468 !     &        LUXLEV,'      p =',LP
19469             twom24 = 1.
19470          do 25 i= 1, 24
19471             twom24 = twom24 * 0.5
19472          k = jseed/53668
19473          jseed = 40014*(jseed-k*53668) -k*12211
19474          if (jseed .lt. 0)  jseed = jseed+icons
19475          iseeds(i) = mod(jseed,itwo24)
19476    25    continue
19477          twom12 = twom24 * 4096.
19478          do 50 i= 1,24
19479          seeds(i) = real(iseeds(i))*twom24
19480          next(i) = i-1
19481    50    continue
19482          next(1) = 24
19483          i24 = 24
19484          j24 = 10
19485          carry = 0.
19486          if (seeds(24) .eq. 0.) carry = twom24
19487       endif
19488 !
19489 !          The Generator proper: "Subtract-with-borrow",
19490 !          as proposed by Marsaglia and Zaman,
19491 !          Florida State University, March, 1989
19492 !
19493       do 100 ivec= 1, lenv
19494       uni = seeds(j24) - seeds(i24) - carry
19495       if (uni .lt. 0.)  then
19496          uni = uni + 1.
19497          carry = twom24
19498       else
19499          carry = 0.
19500       endif
19501       seeds(i24) = uni
19502       i24 = next(i24)
19503       j24 = next(j24)
19504       rvec(ivec) = uni
19505 !  small numbers (with less than 12 "significant" bits) are "padded".
19506       if (uni .lt. twom12)  then
19507          rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
19508 !        and zero is forbidden in case someone takes a logarithm
19509          if (rvec(ivec) .eq. 0.)  rvec(ivec) = twom24*twom24
19510       endif
19511 !        Skipping to luxury.  As proposed by Martin Luscher.
19512       in24 = in24 + 1
19513       if (in24 .eq. 24)  then
19514          in24 = 0
19515          kount = kount + nskip
19516          do 90 isk= 1, nskip
19517          uni = seeds(j24) - seeds(i24) - carry
19518          if (uni .lt. 0.)  then
19519             uni = uni + 1.
19520             carry = twom24
19521          else
19522             carry = 0.
19523          endif
19524          seeds(i24) = uni
19525          i24 = next(i24)
19526          j24 = next(j24)
19527    90    continue
19528       endif
19529   100 continue
19530       kount = kount + lenv
19531       if (kount .ge. igiga)  then
19532          mkount = mkount + 1
19533          kount = kount - igiga
19534       endif
19535       return
19536 !
19537 !           Entry to input and float integer seeds from previous run
19538       entry rluxin(isdext)
19539          notyet = .false.
19540          twom24 = 1.
19541          do 195 i= 1, 24
19542          next(i) = i-1
19543   195    twom24 = twom24 * 0.5
19544          next(1) = 24
19545          twom12 = twom24 * 4096.
19546       write(*,*) ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
19547       write(*,'(5X,5I12)') isdext
19548       do 200 i= 1, 24
19549       seeds(i) = real(isdext(i))*twom24
19550   200 continue
19551       carry = 0.
19552       if (isdext(25) .lt. 0)  carry = twom24
19553       isd = iabs(isdext(25))
19554       i24 = mod(isd,100)
19555       isd = isd/100
19556       j24 = mod(isd,100)
19557       isd = isd/100
19558       in24 = mod(isd,100)
19559       isd = isd/100
19560       luxlev = isd
19561         if (luxlev .le. maxlev) then
19562           nskip = ndskip(luxlev)
19563           write(*,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',  &
19564      &luxlev
19565         else  if (luxlev .ge. 24) then
19566           nskip = luxlev - 24
19567           write(*,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',luxlev
19568         else
19569           nskip = ndskip(maxlev)
19570           write(*,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',luxlev
19571           luxlev = maxlev
19572         endif
19573       inseed = -1
19574       return
19575 !
19576 !                    Entry to ouput seeds as integers
19577       entry rluxut(isdext)
19578       do 300 i= 1, 24
19579          isdext(i) = int(seeds(i)*twop12*twop12)
19580   300 continue
19581       isdext(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
19582       if (carry .gt. 0.)  isdext(25) = -isdext(25)
19583       return
19584 !
19585 !                    Entry to output the "convenient" restart point
19586       entry rluxat(lout,inout,k1,k2)
19587       lout = luxlev
19588       inout = inseed
19589       k1 = kount
19590       k2 = mkount
19591       return
19592 !
19593 !                    Entry to initialize from one or three integers
19594       entry rluxgo(lux,ins,k1,k2)
19595          if (lux .lt. 0) then
19596             luxlev = lxdflt
19597          else if (lux .le. maxlev) then
19598             luxlev = lux
19599          else if (lux .lt. 24 .or. lux .gt. 2000) then
19600             luxlev = maxlev
19601             write(*,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',lux
19602          else
19603             luxlev = lux
19604             do 310 ilx= 0, maxlev
19605               if (lux .eq. ndskip(ilx)+24)  luxlev = ilx
19606   310       continue
19607          endif
19608       if (luxlev .le. maxlev)  then
19609          nskip = ndskip(luxlev)
19610          write(*,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', &
19611      &luxlev,'     P=', nskip+24
19612       else
19613           nskip = luxlev - 24
19614           write(*,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',luxlev
19615       endif
19616       in24 = 0
19617       if (ins .lt. 0)  write(*,*)                                       &
19618      &' Illegal initialization by RLUXGO, negative input seed'
19619       if (ins .gt. 0)  then
19620         jseed = ins
19621         write(*,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', &
19622      &jseed, k1,k2
19623       else
19624         jseed = jsdflt
19625         write(*,*)' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
19626       endif
19627       inseed = jseed
19628       notyet = .false.
19629       twom24 = 1.
19630          do 325 i= 1, 24
19631            twom24 = twom24 * 0.5
19632          k = jseed/53668
19633          jseed = 40014*(jseed-k*53668) -k*12211
19634          if (jseed .lt. 0)  jseed = jseed+icons
19635          iseeds(i) = mod(jseed,itwo24)
19636   325    continue
19637       twom12 = twom24 * 4096.
19638          do 350 i= 1,24
19639          seeds(i) = real(iseeds(i))*twom24
19640          next(i) = i-1
19641   350    continue
19642       next(1) = 24
19643       i24 = 24
19644       j24 = 10
19645       carry = 0.
19646       if (seeds(24) .eq. 0.) carry = twom24
19647 !        If restarting at a break point, skip K1 + IGIGA*K2
19648 !        Note that this is the number of numbers delivered to
19649 !        the user PLUS the number skipped (if luxury .GT. 0).
19650       kount = k1
19651       mkount = k2
19652       if (k1+k2 .ne. 0)  then
19653         do 500 iouter= 1, k2+1
19654           inner = igiga
19655           if (iouter .eq. k2+1)  inner = k1
19656           do 450 isk= 1, inner
19657             uni = seeds(j24) - seeds(i24) - carry
19658             if (uni .lt. 0.)  then
19659                uni = uni + 1.
19660                carry = twom24
19661             else
19662                carry = 0.
19663             endif
19664             seeds(i24) = uni
19665             i24 = next(i24)
19666             j24 = next(j24)
19667   450     continue
19668   500   continue
19669 !         Get the right value of IN24 by direct calculation
19670         in24 = mod(kount, nskip+24)
19671         if (mkount .gt. 0)  then
19672            izip = mod(igiga, nskip+24)
19673            izip2 = mkount*izip + in24
19674            in24 = mod(izip2, nskip+24)
19675         endif
19676 !       Now IN24 had better be between zero and 23 inclusive
19677         if (in24 .gt. 23) then
19678            write(*,'(A/A,3I11,A,I5)')                                   &
19679      &'  Error in RESTARTING with RLUXGO:','  The values', ins,         &
19680      &k1, k2, ' cannot occur at luxury level', luxlev
19681            in24 = 0
19682         endif
19683       endif
19684       return
19685       end
19686  
19687 !cccccccccccccccccccccccccccccccccccccccccccccccccc
19688       subroutine funlxp (func,xfcum,x2low,x2high)
19689 !         F. JAMES,   Sept, 1994
19690 !
19691 !         Prepares the user function FUNC for FUNLUX
19692 !         Inspired by and mostly copied from FUNPRE and FUNRAN
19693 !         except that
19694 !    1. FUNLUX uses RANLUX underneath,
19695 !    2. FUNLXP expands the first and last bins to cater for
19696 !              functions with long tails on left and/or right,
19697 !    3. FUNLXP calls FUNPCT to do the actual finding of percentiles.
19698 !    4. both FUNLXP and FUNPCT use RADAPT for Gaussian integration.
19699 !
19700       implicit none
19701       external func
19702       integer ifunc,ierr
19703       real x2high,x2low,xfcum,rteps,xhigh,xlow,xrange,uncert,x2,tftot1, &
19704      &x3,tftot2,func
19705       real tftot
19706       common/funint/tftot
19707       dimension xfcum(200)
19708       parameter (rteps=0.0002)
19709       save ifunc
19710       data ifunc/0/
19711       ifunc = ifunc + 1
19712 !         FIND RANGE WHERE FUNCTION IS NON-ZERO.
19713       call funlz(func,x2low,x2high,xlow,xhigh)
19714       xrange = xhigh-xlow
19715       if(xrange .le. 0.)  then
19716         write(*,'(A,2G15.5)') ' FUNLXP finds function range .LE.0',     &
19717      &xlow,xhigh
19718         go to 900
19719       endif
19720       call radapt(func,xlow,xhigh,1,rteps,0.,tftot ,uncert)
19721 !      WRITE(6,1003) IFUNC,XLOW,XHIGH,TFTOT
19722  1003 format(' FUNLXP: integral of USER FUNCTION',                      &
19723      &i3,' from ',e12.5,' to ',e12.5,' is ',e14.6)
19724 !
19725 !      WRITE (6,'(A,A)') ' FUNLXP preparing ',
19726 !     + 'first the whole range, then left tail, then right tail.'
19727       call funpct(func,ifunc,xlow,xhigh,xfcum,1,99,tftot,ierr)
19728       if (ierr .gt. 0)  go to 900
19729       x2 = xfcum(3)
19730       call radapt(func,xlow,x2,1,rteps,0.,tftot1 ,uncert)
19731       call funpct(func,ifunc,xlow,x2 ,xfcum,101,49,tftot1,ierr)
19732       if (ierr .gt. 0)  go to 900
19733       x3 = xfcum(98)
19734       call radapt(func,x3,xhigh,1,rteps,0.,tftot2 ,uncert)
19735       call funpct(func,ifunc,x3,xhigh,xfcum,151,49,tftot2,ierr)
19736       if (ierr .gt. 0)  go to 900
19737 !      WRITE(6,1001) IFUNC,XLOW,XHIGH
19738  1001 format(' FUNLXP has prepared USER FUNCTION',i3,                   &
19739      &' between',g12.3,' and',g12.3,' for FUNLUX')
19740       return
19741   900 continue
19742       write(*,*) ' Fatal error in FUNLXP. FUNLUX will not work.'
19743       end
19744 !
19745       subroutine funpct(func,ifunc,xlow,xhigh,xfcum,nlo,nbins,tftot,    &
19746      &ierr)
19747 !        Array XFCUM is filled from NLO to NLO+NBINS, which makes
19748 !        the number of values NBINS+1, or the number of bins NBINS
19749       implicit none
19750       external func
19751       integer ierr,nbins,nlo,ifunc,nz,ibin,maxz,iz,nitmax,ihome
19752       real tftot,xhigh,xlow,func,xfcum,rteps,tpctil,tz,tzmax,x,f,tcum,  &
19753      &x1,f1,dxmax,fmin,fminz,xincr,tincr,xbest,dtbest,tpart,x2,precis,  &
19754      &refx,uncert,tpart2,dtpar2,dtabs,aberr
19755       dimension xfcum(*)
19756       parameter (rteps=0.005, nz=10, maxz=20, nitmax=6,precis=1e-6)
19757 !      DOUBLE PRECISION TPCTIL, TZ, TCUM, XINCR, DTABS,
19758 !     &  TINCR, TZMAX, XBEST, DTBEST, DTPAR2
19759 !
19760       ierr = 0
19761       if (tftot .le. 0.) go to 900
19762       tpctil = tftot/nbins
19763       tz = tpctil/nz
19764       tzmax = tz * 2.
19765       xfcum(nlo) = xlow
19766       xfcum(nlo+nbins) = xhigh
19767       x = xlow
19768       f = func(x)
19769       if (f .lt. 0.) go to 900
19770 !         Loop over percentile bins
19771       do 600 ibin = nlo, nlo+nbins-2
19772       tcum = 0.
19773       x1 = x
19774       f1 = f
19775       dxmax = (xhigh -x) / nz
19776       fmin = tz/dxmax
19777       fminz = fmin
19778 !         Loop over trapezoids within a supposed percentil
19779       do 500 iz= 1, maxz
19780       xincr = tz/max(f1,fmin,fminz)
19781   350 x = x1 + xincr
19782       f = func(x)
19783       if (f .lt. 0.) go to 900
19784       tincr = (x-x1) * 0.5 * (f+f1)
19785       if (tincr .lt. tzmax) go to 370
19786       xincr = xincr * 0.5
19787       go to 350
19788   370 continue
19789       tcum = tcum + tincr
19790       if (tcum .ge. tpctil*0.99) go to 520
19791       fminz = tz*f/ (tpctil-tcum)
19792       f1 = f
19793       x1 = x
19794   500 continue
19795       write(*,*) ' FUNLUX:  WARNING. FUNPCT fails trapezoid.'
19796 !         END OF TRAPEZOID LOOP
19797 !         Adjust interval using Gaussian integration with
19798 !             Newton corrections since F is the derivative
19799   520 continue
19800       x1 = xfcum(ibin)
19801       xbest = x
19802       dtbest = tpctil
19803       tpart = tpctil
19804 !         Allow for maximum NITMAX more iterations on RADAPT
19805       do 550 ihome= 1, nitmax
19806   535 xincr = (tpctil-tpart) / max(f,fmin)
19807       x = xbest + xincr
19808       x2 = x
19809         if (ihome .gt. 1 .and. x2 .eq. xbest) then
19810         write(*,'(A,G12.3)')                                            &
19811      &' FUNLUX: WARNING from FUNPCT: insufficient precision at X=',x
19812         go to 580
19813         endif
19814       refx = abs(x)+precis
19815       call radapt(func,x1,x2,1,rteps,0.,tpart2,uncert)
19816       dtpar2 = tpart2-tpctil
19817       dtabs = abs(dtpar2)
19818       if(abs(xincr)/refx .lt. precis) goto 545
19819       if(dtabs .lt. dtbest) goto 545
19820       xincr = xincr * 0.5
19821       goto 535
19822   545 dtbest = dtabs
19823       xbest = x
19824       tpart = tpart2
19825       f = func(x)
19826       if(f .lt. 0.) goto 900
19827       if(dtabs .lt. rteps*tpctil) goto 580
19828   550 continue
19829       write(*,'(A,I4)')                                                 &
19830      &' FUNLUX: WARNING from FUNPCT: cannot converge, bin',ibin
19831 !
19832   580 continue
19833       xincr = (tpctil-tpart) / max(f,fmin)
19834       x = xbest + xincr
19835       xfcum(ibin+1) = x
19836       f = func(x)
19837       if(f .lt. 0.) goto 900
19838   600 continue
19839 !         END OF LOOP OVER BINS
19840       x1 = xfcum(nlo+nbins-1)
19841       x2 = xhigh
19842       call radapt(func,x1,x2,1,rteps,0.,tpart ,uncert)
19843       aberr = abs(tpart-tpctil)/tftot
19844 !      WRITE(6,1001) IFUNC,XLOW,XHIGH
19845       if(aberr .gt. rteps)  write(*,1002) aberr
19846       return
19847   900 write(*,1000) x,f
19848       ierr = 1
19849       return
19850  1000 format(/' FUNLUX fatal error in FUNPCT: function negative:'/      &
19851      &,' at X=',e15.6,', F=',e15.6/)
19852 ! 1001 FORMAT(' FUNPCT has prepared USER FUNCTION',I3,
19853 !     + ' between',G12.3,' and',G12.3,' for FUNLUX.')
19854  1002 format(' WARNING: Relative error in cumulative distribution',     &
19855      &' may be as big as',f10.7)
19856       end
19857  
19858 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19859  
19860       subroutine funlux(array,xran,len)
19861 !         Generation of LEN random numbers in any given distribution,
19862 !         by 4-point interpolation in the inverse cumulative distr.
19863 !         which was previously generated by FUNLXP
19864       implicit none
19865       real tftot
19866       common/funint/tftot
19867       integer len,ibuf,j,j1
19868       real array,xran,gap,gapinv,tleft,bright,gaps,gapins,x,p,a,b
19869       dimension array(200)
19870       dimension xran(len)
19871 !  Bin width for main sequence, and its inverse
19872       parameter (gap= 1./99.,  gapinv=99.)
19873 !  Top of left tail, bottom of right tail (each tail replaces 2 bins)
19874       parameter (tleft= 2./99.,bright=97./99.)
19875 !  Bin width for minor sequences (tails), and its inverse
19876       parameter (gaps=tleft/49.,  gapins=1./gaps)
19877 !
19878 !   The array ARRAY is assumed to have the following structure:
19879 !        ARRAY(1-100) contains the 99 bins of the inverse cumulative
19880 !                     distribution of the entire function.
19881 !        ARRAY(101-150) contains the 49-bin blowup of main bins
19882 !                       1 and 2 (left tail of distribution)
19883 !        ARRAY(151-200) contains the 49-bin blowup of main bins
19884 !                       98 and 99 (right tail of distribution)
19885 !
19886       call ranlux(xran,len)
19887  
19888       do 500 ibuf= 1, len
19889       x = xran(ibuf)
19890       j = int(  x    *gapinv) + 1
19891       if (j .lt. 3)  then
19892          j1 = int( x *gapins)
19893              j = j1 + 101
19894              j = max(j,102)
19895              j = min(j,148)
19896          p = (   x -gaps*(j1-1)) * gapins
19897          a = (p+1.0) * array(j+2) - (p-2.0)*array(j-1)
19898          b = (p-1.0) * array(j) - p * array(j+1)
19899          xran(ibuf) = a*p*(p-1.0)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19900       else if (j .gt. 97)  then
19901          j1 = int((x-bright)*gapins)
19902              j = j1 + 151
19903              j = max(j,152)
19904              j = min(j,198)
19905          p = (x -bright -gaps*(j1-1)) * gapins
19906          a = (p+1.0) * array(j+2) - (p-2.0)*array(j-1)
19907          b = (p-1.0) * array(j) - p * array(j+1)
19908          xran(ibuf) = a*p*(p-1.0)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19909       else
19910 !      J = MAX(J,2)
19911 !      J = MIN(J,98)
19912          p = (   x -gap*(j-1)) * gapinv
19913          a = (p+1.) * array(j+2) - (p-2.)*array(j-1)
19914          b = (p-1.) * array(j) - p * array(j+1)
19915          xran(ibuf) = a*p*(p-1.)*0.16666667 + b*(p+1.)*(p-2.)*0.5
19916       endif
19917   500 continue
19918       tftot = x
19919       return
19920       end
19921       subroutine funlz(func,x2low,x2high,xlow,xhigh)
19922 !         FIND RANGE WHERE FUNC IS NON-ZERO.
19923 !         WRITTEN 1980, F. JAMES
19924 !         MODIFIED, NOV. 1985, TO FIX BUG AND GENERALIZE
19925 !         TO FIND SIMPLY-CONNECTED NON-ZERO REGION (XLOW,XHIGH)
19926 !         ANYWHERE WITHIN THE GIVEN REGION (X2LOW,H2HIGH).
19927 !            WHERE 'ANYWHERE' MEANS EITHER AT THE LOWER OR UPPER
19928 !            EDGE OF THE GIVEN REGION, OR, IF IN THE MIDDLE,
19929 !            COVERING AT LEAST 1% OF THE GIVEN REGION.
19930 !         OTHERWISE IT IS NOT GUARANTEED TO FIND THE NON-ZERO REGION.
19931 !         IF FUNCTION EVERYWHERE ZERO, FUNLZ SETS XLOW=XHIGH=0.
19932       implicit none
19933       external func
19934       integer logn,nslice,i,k
19935       real xhigh,xlow,x2high,x2low,func,xmid,xh,xl,xnew
19936       xlow = x2low
19937       xhigh = x2high
19938 !         FIND OUT IF FUNCTION IS ZERO AT ONE END OR BOTH
19939       xmid = xlow
19940       if (func(xlow) .gt. 0.) go to 120
19941       xmid = xhigh
19942       if (func(xhigh) .gt. 0.)  go to 50
19943 !         FUNCTION IS ZERO AT BOTH ENDS,
19944 !         LOOK FOR PLACE WHERE IT IS NON-ZERO.
19945       do 30 logn= 1, 7
19946       nslice = 2**logn
19947       do 20 i= 1, nslice, 2
19948       xmid = xlow + i * (xhigh-xlow) / nslice
19949       if (func(xmid) .gt. 0.)  go to 50
19950    20 continue
19951    30 continue
19952 !         FALLING THROUGH LOOP MEANS CANNOT FIND NON-ZERO VALUE
19953       write(*,554)
19954       write(*,555) xlow, xhigh
19955       xlow = 0.
19956       xhigh = 0.
19957       go to 220
19958 !
19959    50 continue
19960 !         DELETE 'LEADING' ZERO RANGE
19961       xh = xmid
19962       xl = xlow
19963       do 70 k= 1, 20
19964       xnew = 0.5*(xh+xl)
19965       if (func(xnew) .eq. 0.) go to 68
19966       xh = xnew
19967       go to 70
19968    68 xl = xnew
19969    70 continue
19970       xlow = xl
19971       write(*,555) x2low,xlow
19972   120 continue
19973       if (func(xhigh) .gt. 0.) go to 220
19974 !         DELETE 'TRAILING' RANGE OF ZEROES
19975       xl = xmid
19976       xh = xhigh
19977       do 170 k= 1, 20
19978       xnew = 0.5*(xh+xl)
19979       if (func(xnew) .eq. 0.) go to 168
19980       xl = xnew
19981       go to 170
19982   168 xh = xnew
19983   170 continue
19984       xhigh = xh
19985       write(*,555) xhigh, x2high
19986 !
19987   220 continue
19988       return
19989   554 format('0CANNOT FIND NON-ZERO FUNCTION VALUE')
19990   555 format(' FUNCTION IS ZERO FROM X=',e12.5,' TO ',e12.5)
19991       end
19992 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
19993 !
19994 ! $Id: radapt.F,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
19995 !
19996 ! $Log: radapt.F,v $
19997 ! Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
19998 ! Mathlib gen
19999 !
20000 !
20001       subroutine radapt(f,a,b,nseg,reltol,abstol,res,err)
20002  
20003 !     RES = Estimated Integral of F from A to B,
20004 !     ERR = Estimated absolute error on RES.
20005 !     NSEG  specifies how the adaptation is to be done:
20006 !        =0   means use previous binning,
20007 !        =1   means fully automatic, adapt until tolerance attained.
20008 !        =n>1 means first split interval into n equal segments,
20009 !             then adapt as necessary to attain tolerance.
20010 !     The specified tolerances are:
20011 !            relative: RELTOL ;  absolute: ABSTOL.
20012 !        It stop s when one OR the other is satisfied, or number of
20013 !        segments exceeds NDIM.  Either TOLA or TOLR (but not both!)
20014 !        can be set to zero, in which case only the other is used.
20015  
20016       implicit none
20017       external f
20018       integer nseg,ndim,nter,nsegd,i,iter,ibig
20019       real err,res,abstol,reltol,b,a,xlo,xhi,tval,ters,te,root,xhib,    &
20020      &bin,xlob,bige,hf,xnew,r1,f
20021       double precision tvals,terss
20022  
20023       parameter (ndim=100)
20024       parameter (r1 = 1., hf = r1/2.)
20025  
20026       dimension xlo(ndim),xhi(ndim),tval(ndim),ters(ndim)
20027       save xlo,xhi,tval,ters,nter
20028       data nter /0/
20029  
20030       if(nseg .le. 0)  then
20031        if(nter .eq. 0) then
20032         nsegd=1
20033         go to 2
20034        endif
20035        tvals=0d0
20036        terss=0d0
20037        do 1 i = 1,nter
20038        call rgs56p(f,xlo(i),xhi(i),tval(i),te)
20039        ters(i)=te**2
20040        tvals=tvals+tval(i)
20041        terss=terss+ters(i)
20042     1  continue
20043        root= sqrt(2.*terss)
20044        go to 9
20045       endif
20046       nsegd=min(nseg,ndim)
20047     2 xhib=a
20048       bin=(b-a)/nsegd
20049       do 3 i = 1,nsegd
20050       xlo(i)=xhib
20051       xlob=xlo(i)
20052       xhi(i)=xhib+bin
20053       if(i .eq. nsegd) xhi(i)=b
20054       xhib=xhi(i)
20055       call rgs56p(f,xlob,xhib,tval(i),te)
20056       ters(i)=te**2
20057     3 continue
20058       nter=nsegd
20059       do 4 iter = 1,ndim
20060       tvals=tval(1)
20061       terss=ters(1)
20062       do 5 i = 2,nter
20063       tvals=tvals+tval(i)
20064       terss=terss+ters(i)
20065     5 continue
20066       root= sqrt(2.*terss)
20067       if(root .le. abstol .or. root .le. reltol*abs(tvals)) go to 9
20068       if(nter .eq. ndim) go to 9
20069       bige=ters(1)
20070       ibig=1
20071       do 6 i = 2,nter
20072       if(ters(i) .gt. bige) then
20073        bige=ters(i)
20074        ibig=i
20075       endif
20076     6 continue
20077       nter=nter+1
20078       xhi(nter)=xhi(ibig)
20079       xnew=hf*(xlo(ibig)+xhi(ibig))
20080       xhi(ibig)=xnew
20081       xlo(nter)=xnew
20082       call rgs56p(f,xlo(ibig),xhi(ibig),tval(ibig),te)
20083       ters(ibig)=te**2
20084       call rgs56p(f,xlo(nter),xhi(nter),tval(nter),te)
20085       ters(nter)=te**2
20086     4 continue
20087     9 res=tvals
20088       err=root
20089       return
20090       end
20091  
20092 !cccccccccccccccccccccccccccccccccccccccccccccccccccccc
20093  
20094 !
20095 ! $Id: rgs56p.F,v 1.1.1.1 1996/04/01 15:02:14 mclareni Exp $
20096 !
20097 ! $Log: rgs56p.F,v $
20098 ! Revision 1.1.1.1  1996/04/01 15:02:14  mclareni
20099 ! Mathlib gen
20100 !
20101 !
20102       subroutine rgs56p(f,a,b,res,err)
20103       implicit none
20104       integer i
20105       real err,res,b,a,f,w6,x6,w5,x5,rang,r1,hf
20106       double precision e5,e6
20107  
20108       parameter (r1 = 1., hf = r1/2.)
20109       dimension x5(5),w5(5),x6(6),w6(6)
20110  
20111       data (x5(i),w5(i),i=1,5)                                          &
20112      &/4.6910077030668004e-02, 1.1846344252809454e-01,                  &
20113      &2.3076534494715846e-01, 2.3931433524968324e-01,                   &
20114      &5.0000000000000000e-01, 2.8444444444444444e-01,                   &
20115      &7.6923465505284154e-01, 2.3931433524968324e-01,                   &
20116      &9.5308992296933200e-01, 1.1846344252809454e-01/
20117  
20118       data (x6(i),w6(i),i=1,6)                                          &
20119      &/3.3765242898423989e-02, 8.5662246189585178e-02,                  &
20120      &1.6939530676686775e-01, 1.8038078652406930e-01,                   &
20121      &3.8069040695840155e-01, 2.3395696728634552e-01,                   &
20122      &6.1930959304159845e-01, 2.3395696728634552e-01,                   &
20123      &8.3060469323313225e-01, 1.8038078652406930e-01,                   &
20124      &9.6623475710157601e-01, 8.5662246189585178e-02/
20125  
20126       rang=b-a
20127       e5=0d0
20128       e6=0d0
20129       do 1 i = 1,5
20130       e5=e5+w5(i)*f(a+rang*x5(i))
20131       e6=e6+w6(i)*f(a+rang*x6(i))
20132     1 continue
20133       e6=e6+w6(6)*f(a+rang*x6(6))
20134       res=hf*(e6+e5)*rang
20135       err=abs((e6-e5)*rang)
20136       return
20137       end
20138 !GRD
20139 !
20140 !*********************************************************************
20141 !
20142 ! Define INTEGER function MCLOCK that can differ from system to system
20143 !
20144 !*********************************************************************
20145 !
20146       integer function mclock_liar( )
20147 !
20148       implicit none
20149       save
20150 !
20151       integer    mclock
20152       integer    count_rate, count_max
20153       logical    clock_ok
20154 !
20155 !        MCLOCK_LIAR = MCLOCK()
20156 !
20157       clock_ok = .true.
20158 !
20159       if (clock_ok) then
20160 !
20161          call system_clock( mclock, count_rate, count_max )
20162          if ( count_max .eq. 0 ) then
20163             clock_ok = .false.
20164             write(*,*)'INFO>  System Clock not present or not',         &
20165      &' Responding'
20166             write(*,*)'INFO>  R.N.G. Reseed operation disabled.'
20167          endif
20168 !
20169       endif
20170 !
20171       mclock_liar = mclock
20172 !
20173       return
20174       end
20175       double precision function ran_gauss(cut)
20176 !*********************************************************************
20177 !
20178 ! RAN_GAUSS - will generate a normal distribution from a uniform
20179 !   distribution between [0,1].
20180 !   See "Communications of the ACM", V. 15 (1972), p. 873.
20181 !
20182 ! cut - double precision - cut for distribution in units of sigma
20183 !                the cut must be greater than 0.5
20184 !
20185 !*********************************************************************
20186       implicit none
20187  
20188       logical flag
20189       real rndm4
20190       double precision x, u1, u2, twopi, r,cut
20191       save
20192  
20193             twopi=8d0*atan(1d0)
20194     1       if (flag) then
20195               r = dble(rndm4( ))
20196               r = max(r, 0.5d0**32)
20197               r = min(r, 1d0-0.5d0**32)
20198               u1 = sqrt(-2d0*log( r ))
20199               u2 = dble(rndm4( ))
20200               x = u1 * cos(twopi*u2)
20201             else
20202               x = u1 * sin(twopi*u2)
20203             endif
20204  
20205           flag = .not. flag
20206  
20207 !  cut the distribution if cut > 0.5
20208           if (cut .gt. 0.5d0 .and. abs(x) .gt. cut) goto 1
20209  
20210           ran_gauss = x
20211         return
20212       end
20213         subroutine readcollimator
20214 !
20215       integer I,J,K
20216       integer mbea,mcor,mcop,mmul,mpa,mran,nbb,nblo,nblz,ncom,ncor1,    &
20217      &nelb,nele,nema,ninv,nlya,nmac,nmon1,npart,nper,nplo,npos,nran,    &
20218      &nrco,ntr,nzfz
20219       parameter(npart = 64,nmac = 1)
20220       parameter(nele=5000,nblo=400,nper=16,nelb=140,nblz=15000,         &
20221      &nzfz = 300000,mmul = 11)
20222       parameter(nran = 280000,ncom = 100,mran = 500,mpa = 6,nrco = 5,   &
20223      &nema = 15)
20224       parameter(mcor = 10,mcop = mcor+6, mbea = 15)
20225       parameter(npos = 20000,nlya = 10000,ninv = 1000,nplo = 20000)
20226       parameter(nmon1 = 600,ncor1 = 600)
20227       parameter(ntr = 20,nbb = 160)
20228       integer max_ncoll,max_npart,maxn,numeff,outlun,nc
20229 !UPGRADE January 2005
20230 !     PARAMETER (MAX_NCOLL=68,MAX_NPART=20000,nc=32,NUMEFF=19,
20231       parameter (max_ncoll=100,max_npart=20000,nc=32,numeff=19,         &
20232      &maxn=20000,outlun=54)
20233 !GRD
20234 !GRD THIS BLOC IS COMMON TO MAINCR, DATEN, TRAUTHIN AND THIN6D
20235 !GRD
20236 !APRIL2005
20237       logical do_coll,do_select,do_nominal,dowrite_dist,do_oneside,     &
20238      &dowrite_impact,dowrite_secondary,dowrite_amplitude,radial,        &
20239      &systilt_antisymm,dowritetracks,cern,do_nsig,do_mingap
20240 !     &systilt_antisymm,dowritetracks,cern
20241 !APRIL2005
20242 !
20243 !      integer nloop,rnd_seed,ibeam,jobnumber,sigsecut2
20244 !JUNE2005
20245 !      integer nloop,rnd_seed,ibeam,jobnumber
20246 !SEPT2005 for slicing process
20247 !      integer nloop,rnd_seed,ibeam,jobnumber,do_thisdis
20248       integer nloop,rnd_seed,c_offsettilt_seed,ibeam,jobnumber,         &
20249      &do_thisdis,n_slices,pencil_distr
20250 !JUNE2005
20251 !
20252 !UPGRADE JANUARY 2005
20253 !APRIL2005
20254 !      double precision myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec, &
20255 !     &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,         &
20256       double precision myenom,mynex,mdex,myney,mdey,                    &
20257      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
20258      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
20259 !
20260      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
20261      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
20262 !
20263      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
20264 !SEPT2005 add these lines for the slicing procedure
20265      &smin_slices,smax_slices,recenter1,recenter2,                      &
20266      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
20267      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
20268 !SEPT2005,OCT2006 added offset
20269      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
20270      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
20271      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
20272      &c_sysoffset_sec,c_rmserror_gap,nr,ndr,                            &
20273 !     &driftsx,driftsy,pencil_offset,sigsecut3
20274 !JUNE2005
20275 !     &driftsx,driftsy,pencil_offset,sigsecut3,sigsecut2
20276      &driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,            &
20277      &sigsecut3,sigsecut2,enerror,bunchlength
20278 !JUNE2005
20279 !APRIL2005
20280 !
20281       character*24 name_sel
20282       character*80 coll_db
20283       character*16 castordir
20284 !JUNE2005
20285       character*80 filename_dis
20286 !JUNE2005
20287 !
20288 !UPGRADE JANUARY 2005
20289 !APRIL2005
20290 !JUNE2005
20291 !SEPT2005
20292 !      common /grd/ myenom,mynex,mdex,myney,mdey,nsig_prim,nsig_sec,     &
20293 !     &nsig_ter,emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,         &
20294 !     &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,nr,     &
20295 !     &ndr,driftsx,driftsy,pencil_offset,sigsecut3,coll_db,name_sel,     &
20296 !     &castordir,abs_db,nloop,rnd_seed,ibeam,jobnumber,sigsecut2,do_coll,&
20297 !     &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
20298 !     &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
20299 !     &dowritetracks,cern
20300       common /grd/ myenom,mynex,mdex,myney,mdey,                        &
20301      &nsig_tcp3,nsig_tcsg3,nsig_tcsm3,nsig_tcla3,                       &
20302      &nsig_tcp7,nsig_tcsg7,nsig_tcsm7,nsig_tcla7,nsig_tclp,nsig_tcli,   &
20303 !
20304      &nsig_tcth1,nsig_tcth2,nsig_tcth5,nsig_tcth8,                      &
20305      &nsig_tctv1,nsig_tctv2,nsig_tctv5,nsig_tctv8,                      &
20306 !
20307      &nsig_tcdq,nsig_tcstcdq,nsig_tdi,nsig_tcxrp,nsig_tcryo, nsig_cry,  &
20308 !
20309      &smin_slices,smax_slices,recenter1,recenter2,                      &
20310      &fit1_1,fit1_2,fit1_3,fit1_4,fit1_5,fit1_6,ssf1,                   &
20311      &fit2_1,fit2_2,fit2_3,fit2_4,fit2_5,fit2_6,ssf2,                   &
20312 !
20313      &emitx0,emity0,xbeat,xbeatphase,ybeat,ybeatphase,                  &
20314      &c_rmstilt_prim,c_rmstilt_sec,c_systilt_prim,c_systilt_sec,        &
20315      &c_rmsoffset_prim,c_rmsoffset_sec,c_sysoffset_prim,                &
20316      &c_sysoffset_sec,c_rmserror_gap,nr,                                &
20317 !
20318      &ndr,driftsx,driftsy,pencil_offset,pencil_rmsx,pencil_rmsy,        &
20319      &sigsecut3,sigsecut2,enerror,                                      &
20320      &bunchlength,coll_db,name_sel,                                     &
20321      &castordir,filename_dis,nloop,rnd_seed,c_offsettilt_seed,          &
20322      &ibeam,jobnumber,do_thisdis,n_slices,pencil_distr,                 &
20323      &do_coll,                                                          &
20324 !
20325      &do_select,do_nominal,dowrite_dist,do_oneside,dowrite_impact,      &
20326      &dowrite_secondary,dowrite_amplitude,radial,systilt_antisymm,      &
20327      &dowritetracks,cern,do_nsig,do_mingap
20328 !SEPT2005
20329 !JUNE2005
20330 !APRIL2005
20331 !
20332 !--September 2006 -- TW common to readcollimator and collimate2
20333 !      logical           changed_tilt1(max_ncoll)
20334 !      logical           changed_tilt2(max_ncoll)
20335 !      common /tilt/ changed_tilt1, changed_tilt2
20336 !--September 2006
20337 !
20338 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
20339 !
20340 !
20341 ! THIS BLOCK IS COMMON TO BOTH THIN6D AND TRAUTHIN SUBROUTINES
20342 !
20343       integer ieff
20344       double precision myemitx0,myemity0,myalphay,mybetay,myalphax,     &
20345      &mybetax,rselect
20346       common /ralph/ myemitx0,myemity0,myalphax,myalphay,mybetax,       &
20347      &mybetay,rselect
20348 !
20349       integer absorbed(npart),counted(npart,numeff)
20350       double precision neff(numeff),rsig(numeff)
20351       common  /eff/ neff,rsig,counted,absorbed
20352 !
20353       integer  nimpact(50)
20354       double precision sumimpact(50),sqsumimpact(50)
20355       common  /rimpact/ sumimpact,sqsumimpact,nimpact
20356 !
20357       integer  nampl(nblz)
20358       character*16  ename(nblz)
20359       double precision sum_ax(nblz),sqsum_ax(nblz),sum_ay(nblz),        &
20360      &sqsum_ay(nblz),sampl(nblz)
20361       common  /ampl_rev/ sum_ax,sqsum_ax,sum_ay,sqsum_ay,sampl,ename,   &
20362      &nampl
20363 !
20364       double precision neffx(numeff),neffy(numeff)
20365       common /efficiency/ neffx,neffy
20366 !
20367       integer part_hit(maxn),part_abs(maxn),n_tot_absorbed,n_absorbed   &
20368      &,part_select(maxn)
20369       double precision part_impact(maxn)
20370       common /stats/ part_impact,part_hit,part_abs
20371       common /n_tot_absorbed/ n_tot_absorbed,n_absorbed
20372       common /part_select/ part_select
20373 !
20374       double precision x00(maxn),xp00(maxn),y00(maxn),yp00(maxn)
20375       common   /beam00/ x00,xp00,y00,yp00
20376 !
20377       logical firstrun
20378       common /firstrun/ firstrun
20379 !
20380       integer nsurvive,nsurvive_end,num_selhit,n_impact
20381       common /outcoll/ nsurvive,num_selhit,n_impact,nsurvive_end
20382 !
20383       integer napx00
20384       common /napx00/ napx00
20385 !
20386       integer  icoll
20387       common  /icoll/  icoll
20388 !
20389 !UPGRADE January 2005
20390 !     INTEGER DB_NCOLL
20391       integer db_ncoll
20392 !
20393       character*16 db_name1(max_ncoll),db_name2(max_ncoll)
20394       character*6 db_material(max_ncoll)
20395 !APRIL2005
20396       double precision db_nsig(max_ncoll),db_length(max_ncoll),         &
20397      &db_offset(max_ncoll),db_rotation(max_ncoll),                      &
20398      &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2),           &
20399      &db_elense_thickness(max_ncoll),db_elense_j_e(max_ncoll)           &
20400      &,db_cry_rcurv(max_ncoll),db_cry_rmax(max_ncoll),                  &
20401      &db_cry_zmax(max_ncoll),db_cry_alayer(max_ncoll),                  &
20402      &db_cry_orient(max_ncoll),db_cry_tilt(max_ncoll)
20403      &,db_miscut(max_ncoll)
20404       common /colldatabase/ db_nsig,db_length,db_rotation,db_offset,    &
20405      &db_bx,db_by,db_tilt,db_name1,db_name2,db_material,db_ncoll,       &
20406      &db_elense_thickness,db_elense_j_e                                 &
20407      &,db_cry_rcurv,db_cry_rmax,db_cry_zmax,db_cry_alayer,db_cry_orient,&
20408      &db_cry_tilt,db_miscut
20409
20410 !      double precision db_length(max_ncoll),db_rotation(max_ncoll),     &
20411 !     &db_offset(max_ncoll),                                             &
20412 !     &db_bx(max_ncoll),db_by(max_ncoll),db_tilt(max_ncoll,2)
20413 !      common /colldatabase/ db_length,db_rotation,db_offset,db_bx,db_by,&
20414 !!    &DB_TILT,DB_NAME1,DB_NAME2,DB_MATERIAL,DB_NCOLL
20415 !     &db_tilt,db_name1,db_name2,db_material,db_ncoll,db_nabs,db_ntot,   &
20416 !     &db_startabs
20417 !APRIL2005
20418 !
20419       integer cn_impact(max_ncoll),cn_absorbed(max_ncoll)
20420       double precision caverage(max_ncoll),csigma(max_ncoll)
20421       common /collsummary/ caverage,csigma,cn_impact,cn_absorbed
20422 !
20423       double precision myx(maxn),myxp(maxn),myy(maxn),myyp(maxn),       &
20424      &myp(maxn),mys(maxn)
20425       common /coord/ myx,myxp,myy,myyp,myp,mys
20426 !
20427       integer counted_r(maxn,numeff),counted_x(maxn,numeff),            &
20428      &counted_y(maxn,numeff),                                           &
20429      &ieffmax_r(npart),ieffmax_x(npart),ieffmax_y(npart)
20430       common /counting/ counted_r,counted_x,counted_y,ieffmax_r,        &
20431      &ieffmax_x, ieffmax_y
20432 !
20433 !APRIL2005
20434 !      integer secondary(maxn),tertiary(maxn),part_hit_before(maxn)
20435       integer secondary(maxn),tertiary(maxn),other(maxn),               &
20436      &part_hit_before(maxn)
20437 !APRIL2005
20438       double precision part_indiv(maxn),part_linteract(maxn)
20439 !
20440       integer   samplenumber
20441       character*4 smpl
20442       character*80 pfile
20443       common /samplenumber/ pfile,smpl,samplenumber
20444 !
20445 !-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
20446 !
20447 !
20448       save
20449 !
20450 !--------------------------------------------------------------------
20451 !++  Read collimator database
20452 !
20453 !      write(*,*) 'reading collimator database'
20454       open(unit=53,file=coll_db)
20455 !
20456 !      write(*,*) 'inside collimator database'
20457       I = 0
20458       read(53,*)
20459       read(53,*,iostat=ios) db_ncoll
20460 !     write(*,*) 'ios = ',ios
20461       if (ios.ne.0) then
20462         write(outlun,*) 'ERR>  Problem reading collimator DB ',ios
20463         stop
20464       endif
20465       if (db_ncoll.gt.max_ncoll) then
20466          write(*,*) 'ERR> db_ncoll > max_ncoll '
20467          stop
20468       endif
20469 !
20470       do j=1,db_ncoll
20471 !      write(*,*) 'inside collimator database',j
20472       read(53,*)
20473 !GRD
20474 !GRD ALLOW TO RECOGNIZE BOTH CAPITAL AND NORMAL LETTERS
20475 !GRD
20476         read(53,*,iostat=ios) db_name1(j)
20477 !        write(*,*) 'ios = ',ios
20478         if (ios.ne.0) then
20479           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20480           stop
20481         endif
20482 !
20483         read(53,*,iostat=ios) db_name2(j)
20484 !        write(*,*) 'ios = ',ios
20485         if (ios.ne.0) then
20486           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20487           stop
20488         endif
20489 !
20490         read(53,*,iostat=ios) db_nsig(j)
20491 !        write(*,*) 'ios = ',ios
20492         if (ios.ne.0) then
20493           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20494           stop
20495         endif
20496 !GRD
20497         read(53,*,iostat=ios) db_material(j)
20498 !        write(*,*) 'ios = ',ios
20499         if (ios.ne.0) then
20500           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20501           stop
20502         endif
20503         read(53,*,iostat=ios) db_length(j)
20504 !        write(*,*) 'ios = ',ios
20505         if (ios.ne.0) then
20506           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20507           stop
20508         endif
20509         read(53,*,iostat=ios) db_rotation(j)
20510 !        write(*,*) 'ios = ',ios
20511         if (ios.ne.0) then
20512           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20513           stop
20514         endif
20515         read(53,*,iostat=ios) db_offset(j)
20516 !        write(*,*) 'ios = ',ios
20517         if (ios.ne.0) then
20518           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20519           stop
20520         endif
20521 c-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-Valentina-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-
20522 c
20523 c        for crystal I need more parameters to be put in the database
20524 c
20525         if (db_name1(j)(1:3).EQ.'CRY') then
20526           READ(53,*,IOSTAT=ios) db_cry_rcurv(j)
20527           if (ios.NE.0) then
20528             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j,  1
20529      1      ios
20530             stop
20531           endif
20532           write(*,*) 'db_cry_rcurv(j)', db_cry_rcurv(j)
20533           READ(53,*,IOSTAT=ios) db_cry_rmax(j)
20534           if (ios.NE.0) then
20535             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j,  1
20536      1      ios
20537             STOP
20538           endif
20539           write(*,*) 'db_cry_rmax(j)', db_cry_rmax(j)
20540           READ(53,*,IOSTAT=ios) db_cry_zmax(j)
20541           if (ios.NE.0) then
20542             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j,  1
20543      1      ios
20544             STOP
20545           endif
20546           write(*,*) 'db_cry_zmax(j)', db_cry_zmax(j)
20547           READ(53,*,IOSTAT=ios) db_cry_alayer(j)
20548           if (ios.NE.0) then
20549             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j,  1
20550      1      ios
20551             STOP
20552           endif
20553           write(*,*) 'db_cry_alayer(j)', db_cry_alayer(j)
20554           READ(53,*,IOSTAT=ios) db_cry_orient(j)
20555           if (ios.NE.0) then
20556             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j,  1
20557      1      ios
20558             STOP
20559           endif
20560           write(*,*) 'db_cry_orient(j)',db_cry_orient(j)
20561           READ(53,*,IOSTAT=ios) db_cry_tilt(j)
20562           if (ios.NE.0) then
20563             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j , 1
20564      1      ios
20565             STOP
20566           endif
20567           write(*,*) 'db_cry_tilt(j)', db_cry_tilt(j)
20568           READ(53,*,IOSTAT=ios) db_miscut(j)
20569           if (ios.NE.0) then
20570             WRITE(outlun,*) 'ERR>  Problem reading collimator DB ', j , 1
20571      1      ios
20572             STOP
20573           endif
20574           write(*,*) 'db_miscut(j)', db_miscut(j)
20575         endif
20576 c
20577 c-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-Valentina-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-~-o-
20578         read(53,*,iostat=ios) db_bx(j)
20579 !        write(*,*) 'ios = ',ios
20580         if (ios.ne.0) then
20581           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20582           stop
20583         endif
20584         read(53,*,iostat=ios) db_by(j)
20585 !        write(*,*) 'ios = ',ios
20586         if (ios.ne.0) then
20587           write(outlun,*) 'ERR>  Problem reading collimator DB ', j,ios
20588           stop
20589         endif
20590 !SEPT2008 JCSMITH
20591 ! Add special lines for electron lense
20592         if (db_name1(j)(1:5).eq.'ELENS') then                           &
20593           read(53,*,iostat=ios) db_elense_thickness(j), db_elense_j_e(j)
20594           if (ios.ne.0) then
20595             write(outlun,*)                                             &
20596      &       'ERR>  Problem reading collimator elense DB ',j,ios
20597             stop
20598           endif
20599         endif
20600       enddo
20601 !
20602       close(53)
20603 !
20604       end